heftia-effects 0.4.0.1 → 0.5.0.0

raw patch · 37 files changed

+2265/−427 lines, 37 filesdep +bytestringdep +co-log-coredep +filepathdep ~data-effectsdep ~heftiadep ~textnew-component:exe:NonDetnew-component:exe:ShiftResetnew-component:exe:Streamnew-component:exe:Subprocessnew-component:exe:UnliftIOPVP ok

version bump matches the API change (PVP)

Dependencies added: bytestring, co-log-core, filepath, process

Dependency ranges changed: data-effects, heftia, text

API changes (from Hackage documentation)

Files

• ChangeLog.md +14/−0
• Example/Continuation2/Main.hs +0/−114
• Example/FileSystemProvider/Main.hs +27/−11
• Example/NonDet/Main.hs +159/−0
• Example/ShiftReset/Main.hs +114/−0
• Example/Stream/Main.hs +127/−0
• Example/Subprocess/Main.hs +25/−0
• Example/UnliftIO/Main.hs +95/−0
• README.md +251/−101
• bench/BenchCatch.hs +1/−3
• bench/BenchCoroutine.hs +0/−1
• bench/BenchCountdown.hs +0/−1
• bench/BenchLocal.hs +114/−0
• bench/BenchPyth.hs +0/−1
• bench/Main.hs +29/−0
• heftia-effects.cabal +59/−11
• src/Control/Monad/Hefty/Concurrent/Parallel.hs +142/−0
• src/Control/Monad/Hefty/Concurrent/Stream.hs +301/−0
• src/Control/Monad/Hefty/Concurrent/Subprocess.hs +280/−0
• src/Control/Monad/Hefty/Concurrent/Timer.hs +14/−2
• src/Control/Monad/Hefty/Coroutine.hs +30/−7
• src/Control/Monad/Hefty/Except.hs +15/−16
• src/Control/Monad/Hefty/Fail.hs +8/−3
• src/Control/Monad/Hefty/Fresh.hs +5/−2
• src/Control/Monad/Hefty/Input.hs +16/−6
• src/Control/Monad/Hefty/KVStore.hs +6/−2
• src/Control/Monad/Hefty/Log.hs +34/−0
• src/Control/Monad/Hefty/NonDet.hs +66/−15
• src/Control/Monad/Hefty/Output.hs +13/−7
• src/Control/Monad/Hefty/Provider.hs +90/−59
• src/Control/Monad/Hefty/Reader.hs +11/−8
• src/Control/Monad/Hefty/Resource.hs +10/−5
• src/Control/Monad/Hefty/ShiftReset.hs +37/−18
• src/Control/Monad/Hefty/State.hs +39/−9
• src/Control/Monad/Hefty/Unlift.hs +15/−9
• src/Control/Monad/Hefty/Writer.hs +20/−16
• test/Test/Concurrent.hs +98/−0

@@ -21,3 +21,17 @@ * Support for the core package update to version 0.4. * Dropped support for GHC 9.2.8, now supporting GHC 9.4.1 and later. * Added benchmarks and tests.++## 0.4.0.1 -- 2024-10-14++* Fixed an issue where builds would fail with Stack: https://github.com/sayo-hs/heftia/issues/15++## 0.5.0.0 -- 2024-11-03++* **New features**+    * Added Concurrent/Parallel effects, Streaming, and Subprocess functionality.+    * Added interpreters for the `co-log` ecosystem.++* Renamed `Control.Monad.Hefty.Writer.listen` -> `intercept`+* Reexported `Data.Effect.*` from the interpreters module `Control.Monad.Hefty.*`.+* Generalized `runUnliftIO` to use any monad that is an instance of `MonadUnliftIO`.

@@ -1,114 +0,0 @@--- 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 Main where--import Control.Effect.Key (key)-import Control.Monad.Extra (whenM)-import Control.Monad.Hefty (-    Eff,-    liftIO,-    raiseH,-    runEff,-    send,-    sendN,-    unkey,-    (&),-    type (!!),-    type ($),-    type (+),-    type (:+:),- )-import Control.Monad.Hefty.Reader (runReader)-import Control.Monad.Hefty.ShiftReset (ShiftFix, evalShift, runShift_, unShiftBase)-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.State (State, get'', modify)-import Data.Functor ((<&>))--main :: IO ()-main = do-    putStrLn "[handleReaderThenShift]"-    handleReaderThenShift--    putStrLn ""-    putStrLn "[handleShiftThenReader]"-    handleShiftThenReader--{--===== result =====--[handleReaderThenShift]-[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--[handleShiftThenReader]-[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--}--handleReaderThenShift :: IO ()-handleReaderThenShift =-    prog-        & runReader 1-        & runEff-        & evalShift-        & (evalState 0 . unkey)-        & runEff-  where-    prog-        :: (r ~ '["counter" #> State Int, IO])-        => Eff '[Local Int] '[Ask Int, Eff '[ShiftFix () '[] r] r] ()-    prog = do-        k <- sendN @1 $ getCC-        env <- ask @Int-        sendN @1 $ liftIO $ putStrLn $ "[local scope outer] env = " ++ show env-        local @Int (* 2) do-            whenM (sendN @1 (get'' @"counter") <&> (< 5)) do-                sendN @1 $ modify (+ 1) & key @"counter"-                env' <- ask @Int-                sendN @1 $ liftIO $ putStrLn $ "[local scope inner] env = " ++ show env'-                send $ unShiftBase k--handleShiftThenReader :: IO ()-handleShiftThenReader = do-    prog-        & runShift_-        & runReader 1-        & (evalState 0 . unkey)-        & runEff-  where-    prog-        :: (r ~ (Ask Int + "counter" #> State Int + IO))-        => Shift_ (Local Int !! r) :+: Local Int !! r $ ()-    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'-                raiseH k

@@ -18,7 +18,7 @@     type (<|),     type (~>),  )-import Control.Monad.Hefty.Provider (ProviderFix_, provide_, runProvider_)+import Control.Monad.Hefty.Provider (Provide_, runProvider_, scope_)  data FileSystemF a where     ReadFS :: FilePath -> FileSystemF String@@ -28,7 +28,7 @@     TransactFS :: m a -> FileSystemH m a makeEffect [''FileSystemF] [''FileSystemH] -type FSProvider eh ef = ProviderFix_ FilePath FileSystemH eh FileSystemF ef+type FSProvider eh ef = Provide_ FilePath FileSystemH FileSystemF eh ef  runDummyFSProvider :: (IO <| ef) => Eff (FSProvider eh ef ': eh) ef ~> Eff eh ef runDummyFSProvider =@@ -49,21 +49,37 @@ main :: IO () main =     runEff . runDummyFSProvider $-        provide_ @"fs1" "/fs1" \_ -> do-            provide_ @"fs2" "/fs2" \inBase -> do-                inBase do-                    s1 <- readFS' @"fs1" "/a/b/c"+        scope_ @"fs1" "/fs1" \_ -> do+            scope_ @"fs2" "/fs2" \outer -> do+                outer do+                    s1 <- readFS'' @"fs1" "/a/b/c"                     liftIO $ putStrLn $ "content: " <> show s1-                    writeFS' @"fs1" "/d/e/f" "foobar"+                    writeFS'' @"fs1" "/d/e/f" "foobar"                  liftIO $ putStrLn "-----" -                s2 <- readFS' @"fs2" "/a/b/c"+                s2 <- readFS'' @"fs2" "/a/b/c"                 liftIO $ putStrLn $ "content: " <> show s2-                writeFS' @"fs2" "/d/e/f" "foobar"+                writeFS'' @"fs2" "/d/e/f" "foobar"                  liftIO $ putStrLn "-----" -                transactFS' @"fs2" do-                    inBase $ transactFS' @"fs1" do+                transactFS'' @"fs2" do+                    outer $ transactFS'' @"fs1" do                         liftIO $ print "hello"++{-+[DUMMY FS /fs1] readFS "/a/b/c"+content: "DUMMY CONTENT on /fs1/a/b/c"+[DUMMY FS /fs1] writeFS "/d/e/f" "foobar"+-----+[DUMMY FS /fs2] readFS "/a/b/c"+content: "DUMMY CONTENT on /fs2/a/b/c"+[DUMMY FS /fs2] writeFS "/d/e/f" "foobar"+-----+[DUMMY FS /fs2] START TRANSACTION+[DUMMY FS /fs1] START TRANSACTION+"hello"+[DUMMY FS /fs1] END TRANSACTION+[DUMMY FS /fs2] END TRANSACTION+-}

@@ -0,0 +1,159 @@+{-# LANGUAGE AllowAmbiguousTypes #-}+{-# LANGUAGE DeriveAnyClass #-}+{-# LANGUAGE TemplateHaskell #-}+{-# OPTIONS_GHC -fplugin GHC.TypeLits.KnownNat.Solver #-}++-- SPDX-License-Identifier: MPL-2.0++module Main where++import Control.Monad.Hefty (+    Eff,+    interpret,+    liftIO,+    makeEffectF,+    runEff,+    (&),+    type (<:),+    type (<|),+    type (~>),+ )+import Control.Monad.Hefty.Except (Throw, joinEither, runThrowIO, throw)+import Control.Monad.Hefty.NonDet (Choose, Empty, choice, runNonDetMonoid)+import Data.Function (fix)+import Data.Functor ((<&>))+import Data.Map (Map)+import Data.Map qualified as Map+import Data.Monoid (Sum (Sum))+import System.FilePath (splitDirectories, (</>))+import UnliftIO (Exception)++-- | Effect for file system operations+data FileSystem a where+    ListDirectory :: FilePath -> FileSystem (Either NotADir [FilePath])+    GetFileSize :: FilePath -> FileSystem (Either NotAFile Integer)++-- | Exception for when a directory was expected but found a file+data NotAFile = NotAFile++-- | Exception for when a file was expected but found a directory+data NotADir = NotADir+    deriving (Show)+    deriving anyclass (Exception)++makeEffectF [''FileSystem]++-- | Exception for when an entry does not exist at the specified path+data EntryNotFound = EntryNotFound+    deriving (Show)+    deriving anyclass (Exception)++-- | Aggregate the sizes of all files under the given path+totalFileSize+    :: (Choose <| ef, Empty <| ef, FileSystem <| ef, Throw NotADir <| ef, IO <| ef)+    => FilePath+    -> Eff '[] ef (Sum Integer)+totalFileSize path = do+    entities :: [FilePath] <- listDirectory path & joinEither+    entity :: FilePath <- choice entities -- Non-deterministically /pick/ one item from the list+    let path' = path </> entity++    liftIO $ putStrLn $ "Found " <> path'++    getFileSize path' >>= \case+        Right size -> do+            liftIO $ putStrLn $ " ... " <> show size <> " bytes"+            pure $ Sum size+        Left NotAFile -> do+            totalFileSize path'++main :: IO ()+main = runEff+    . runThrowIO @EntryNotFound+    . runThrowIO @NotADir+    . runDummyFS exampleRoot+    $ do+        total <- runNonDetMonoid pure (totalFileSize ".")+        liftIO $ print total++{-+>>> main+Found ./README.md+ ... 4000 bytes+Found ./src+Found ./src/Bar.hs+ ... 1000 bytes+Found ./src/Foo.hs+ ... 2000 bytes+Found ./test+Found ./test/Baz.hs+ ... 3000 bytes+Sum {getSum = 10000}+-}++-- | Example directory structure used this time+exampleRoot :: FSTree+exampleRoot =+    dir+        [+            ( "."+            , dir+                [+                    ( "src"+                    , dir+                        [ ("Bar.hs", File 1000)+                        , ("Foo.hs", File 2000)+                        ]+                    )+                ,+                    ( "test"+                    , dir+                        [ ("Baz.hs", File 3000)+                        ]+                    )+                , ("README.md", File 4000)+                ]+            )+        ]+  where+    dir :: [(FilePath, FSTree)] -> FSTree+    dir = Dir . Map.fromList++-- | Directory structure+data FSTree+    = Dir {entries :: Map FilePath FSTree}+    | File {fileSize :: Integer}++{- |+Interpreter for the FileSystem effect that virtualizes the file system in memory+based on a given FSTree, instead of performing actual IO.+-}+runDummyFS+    :: (Throw EntryNotFound <| ef, Throw NotADir <| ef)+    => FSTree+    -> Eff eh (FileSystem ': ef) ~> Eff eh ef+runDummyFS root = interpret \case+    ListDirectory path ->+        lookupFS path root <&> \case+            Dir entries -> Right $ Map.keys entries+            File _ -> Left NotADir+    GetFileSize path ->+        lookupFS path root <&> \case+            File size -> Right size+            Dir _ -> Left NotAFile++-- | Lookup the directory structure by path+lookupFS+    :: (Throw EntryNotFound <: m, Throw NotADir <: m, Monad m)+    => FilePath+    -> FSTree+    -> m FSTree+lookupFS path =+    splitDirectories path & fix \dive -> \case+        [] -> pure+        dirName : restPath -> \case+            Dir currentDir -> do+                case currentDir Map.!? dirName of+                    Just restTree -> dive restPath restTree+                    Nothing -> throw EntryNotFound+            File _ -> throw NotADir

@@ -0,0 +1,114 @@+-- 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 Main where++import Control.Effect.Key (key)+import Control.Monad.Extra (whenM)+import Control.Monad.Hefty (+    Eff,+    liftIO,+    raiseH,+    runEff,+    send,+    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.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.State (State, get'', modify)+import Data.Functor ((<&>))++main :: IO ()+main = do+    putStrLn "[handleReaderThenShift]"+    handleReaderThenShift++    putStrLn ""+    putStrLn "[handleShiftThenReader]"+    handleShiftThenReader++{-+===== result =====++[handleReaderThenShift]+[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++[handleShiftThenReader]+[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+-}++handleReaderThenShift :: IO ()+handleReaderThenShift =+    prog+        & runReader 1+        & runEff+        & evalShift+        & (evalState 0 . unkey)+        & runEff+  where+    prog+        :: (r ~ '["counter" #> State Int, IO])+        => Eff '[Local Int] '[Ask Int, Eff '[Shift () '[] r] r] ()+    prog = do+        ShiftEff k <- sendN @1 $ getCC+        env <- ask @Int+        sendN @1 $ liftIO $ putStrLn $ "[local scope outer] env = " ++ show env+        local @Int (* 2) do+            whenM (sendN @1 (get'' @"counter") <&> (< 5)) do+                sendN @1 $ modify (+ 1) & key @"counter"+                env' <- ask @Int+                sendN @1 $ liftIO $ putStrLn $ "[local scope inner] env = " ++ show env'+                send k++handleShiftThenReader :: IO ()+handleShiftThenReader = do+    prog+        & runShift_+        & runReader 1+        & (evalState 0 . unkey)+        & runEff+  where+    prog+        :: (r ~ (Ask Int + "counter" #> State Int + IO))+        => Shift_ (Local Int !! r) :+: Local Int !! r $ ()+    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'+                raiseH k

@@ -0,0 +1,127 @@+{-# OPTIONS_GHC -fplugin GHC.TypeLits.KnownNat.Solver #-}++-- SPDX-License-Identifier: MPL-2.0++-- This example is based on https://h2.jaguarpaw.co.uk/posts/bluefin-streams-finalize-promptly/+module Main where++import Control.Arrow ((>>>))+import Control.Monad (forever, void, when)+import Control.Monad.Hefty (Eff, liftIO, raiseAllH, type (<:), type (<|))+import Control.Monad.Hefty.Concurrent.Parallel (runParallelIO)+import Control.Monad.Hefty.Concurrent.Stream (+    Input,+    Machinery (Unit),+    Output,+    input,+    output,+    runMachinery,+    runMachineryIO_,+ )+import Control.Monad.Hefty.Concurrent.Timer (Timer, runTimerIO, sleep)+import Control.Monad.Hefty.Except (runThrow, throw)+import Control.Monad.Hefty.Unlift (runUnliftIO)+import Control.Monad.IO.Class (MonadIO)+import Data.Foldable (for_)+import UnliftIO (bracket_)++{- | In reality, this 'throw' operates independently of @bracket@...+because 'runThrow' functions under the semantics of pure algebraic effects,+it operates independently without interfering with 'IO'-level exceptions.++This function is equivalent to the following (as a result of reducing 'runThrow').++@+produce = void do+    for_ [1 .. 4] \(i :: Int) -> do+        output i+        sleep 0.5+@+-}+produce :: (Output Int <| ef, Timer <| ef) => Eff '[] ef ()+produce = void . runThrow @() $+    for_ [1 ..] \(i :: Int) -> do+        when (i == 5) $ throw ()+        output i+        sleep 0.5++consume :: (Input Int <: m, Timer <: m, MonadIO m) => m ()+consume = forever do+    liftIO . print =<< input @Int+    sleep 0.5++plus100 :: (Input Int <: m, Output Int <: m, Timer <: m, MonadIO m) => m ()+plus100 = forever do+    i <- input @Int+    let o = i + 100+    liftIO $ putStrLn $ "Transform " <> show i <> " to " <> show o+    output o+    sleep 0.5++{- |+The difference between `runMachinery` and `runMachineryIO` is that the former+returns a continuation at the point when the stream has paused, allowing the+stream to be resumed later by providing new inputs and handlers. In terms of+algebraic effects, this means that /non-scoped resumption/ is possible.++Conversely, the latter allows the unrestricted use of `bracket`+(`MonadUnliftIO`) internally, but resumption afterwards is not possible.+`runMachineryIO` operates with a mechanism equivalent to the [Bluefin effect library](https://hackage.haskell.org/package/bluefin-0.0.9.0/docs/Bluefin-Stream.html)+and offers the same functionality.+-}+main :: IO ()+main = runUnliftIO . runTimerIO $ do+    liftIO $ putStrLn "[Parallel effect-based (purer & non-IO-fused) machinery interpretation example]"+    _ <-+        runParallelIO . runMachinery $+            Unit @() @Int produce+                >>> Unit @Int @Int plus100+                >>> Unit @Int @() consume++    liftIO $ putStrLn "\n[IO-fused machinery interpretation example]"++    let produceWithBracket =+            bracket_+                (liftIO $ putStrLn "Acquiring resource")+                (liftIO $ putStrLn "Releasing resource")+                (raiseAllH produce)++    runMachineryIO_ $+        Unit @() @Int do+            produceWithBracket+            produceWithBracket+            >>> Unit @Int @Int plus100+            >>> Unit @Int @() consume++{-+Transform 1 to 101+101+Transform 2 to 102+102+Transform 3 to 103+103+Transform 4 to 104+104++[IO-fused machinery interpretation example]+Acquiring resource+Transform 1 to 101+101+Transform 2 to 102+102+Transform 3 to 103+103+Transform 4 to 104+104+Releasing resource+Acquiring resource+Transform 1 to 101+101+Transform 2 to 102+102+Transform 3 to 103+103+Transform 4 to 104+104+Releasing resource+-}

@@ -0,0 +1,25 @@+-- SPDX-License-Identifier: MPL-2.0++module Main where++import Control.Monad.Hefty (liftIO, (&))+import Control.Monad.Hefty.Concurrent.Subprocess (+    CreateProcess (stdout),+    StdStream (CreatePipe),+    SubprocResult,+    readStdout'',+    runSubprocIO,+    scope,+    shell,+ )+import Control.Monad.Hefty.Unlift (runUnliftIO)++main :: IO ()+main = runUnliftIO . runSubprocIO $ do+    r <- scope @"echo" @SubprocResult (shell "echo a b c") {stdout = CreatePipe} \_ -> do+        readStdout'' @"echo"+    print r & liftIO++{-+SubprocScopeResult ExitSuccess "a b c\n"+-}

@@ -0,0 +1,95 @@+{-# LANGUAGE AllowAmbiguousTypes #-}+{-# LANGUAGE TemplateHaskell #-}+{-# OPTIONS_GHC -fplugin GHC.TypeLits.KnownNat.Solver #-}++-- SPDX-License-Identifier: MPL-2.0++module Main where++import Control.Applicative ((<|>))+import Control.Arrow ((>>>))+import Control.Monad.Hefty (+    Eff,+    Type,+    interpret,+    interpretH,+    liftIO,+    makeEffectF,+    makeEffectH,+    raiseAllH,+    type (<<|),+    type (<|),+    type (~>),+ )+import Control.Monad.Hefty.Coroutine (Status (Continue, Done), runCoroutine, yield_)+import Control.Monad.Hefty.NonDet (runChooseH, runNonDetMonoid)+import Control.Monad.Hefty.Resource (runResourceIO)+import Control.Monad.Hefty.Unlift (runUnliftIO)+import Data.Effect.Resource (Resource, bracket_)++data DBF (a :: Type) where+    InsertDB :: Int -> DBF ()+makeEffectF [''DBF]++data DBH m (a :: Type) where+    Transact :: m a -> DBH m a+makeEffectH [''DBH]++runDummyDB :: (Resource <<| eh, IO <| ef) => Eff (DBH ': eh) (DBF ': ef) ~> Eff eh ef+runDummyDB =+    interpretH \case+        Transact m ->+            bracket_+                (liftIO $ putStrLn "[DummyDB] Start transaction.")+                (liftIO $ putStrLn "[DummyDB] End transaction.")+                m+        >>> interpret \case+            InsertDB x -> liftIO $ putStrLn $ "[DummyDB] insertDB " <> show x++main :: IO ()+main =+    runUnliftIO . runResourceIO . runDummyDB $ do+        insertDB 42++        transact do+            insertDB 123+            insertDB 456++            raiseAllH do+                -- Even within the scope of UnliftIO, you can combine+                -- non-deterministic computations...+                runNonDetMonoid (const $ pure ()) . runChooseH $ do+                    insertDB 1 <|> insertDB 2++                -- ...or even use coroutines.+                do+                    status <- runCoroutine do+                        yield_ @Int $ -10+                        insertDB $ -20++                    case status of+                        Done () -> pure ()+                        Continue x resume -> do+                            _ <- resume ()+                            insertDB x+                            pure ()++                -- Note that UnliftIO is disabled within the scope of 'raiseAllH'.+                -- Fitst-order 'IO' operations are still possible.+                liftIO $ putStrLn "The transaction is being finalized..."++        insertDB 789++{-+[DummyDB] insertDB 42+[DummyDB] Start transaction.+[DummyDB] insertDB 123+[DummyDB] insertDB 456+[DummyDB] insertDB 1+[DummyDB] insertDB 2+[DummyDB] insertDB -20+[DummyDB] insertDB -10+The transaction is being finalized...+[DummyDB] End transaction.+[DummyDB] insertDB 789+-}

@@ -1,19 +1,15 @@-# Heftia: higher-order effects done right for Haskell+# Heftia: higher-order algebraic effects done right  [![Hackage](https://img.shields.io/hackage/v/heftia.svg?logo=haskell&label=heftia)](https://hackage.haskell.org/package/heftia) [![Hackage](https://img.shields.io/hackage/v/heftia-effects.svg?logo=haskell&label=heftia-effects)](https://hackage.haskell.org/package/heftia-effects)+[![Stackage](https://www.stackage.org/package/heftia-effects/badge/nightly?label=Stackage)](https://www.stackage.org/package/heftia-effects)+[![Build status](https://img.shields.io/github/actions/workflow/status/sayo-hs/heftia/haskell.yml?branch=develop)](https://github.com/sayo-hs/heftia/actions) -Heftia is an extensible effects library that generalizes "Algebraic Effects and Handlers" to higher-order effects, providing users with maximum flexibility and delivering standard and reasonable speed.+Heftia is an extensible effects library for Haskell that generalizes "Algebraic Effects and Handlers" to higher-order effects, providing users with maximum flexibility and delivering standard and reasonable speed. In its generalization, the focus is on ensuring predictable results based on simple, consistent semantics, while preserving soundness. -Please refer to the [Haddock documentation](https://hackage.haskell.org/package/heftia-0.4.0.0/docs/Control-Monad-Hefty.html) for usage and semantics.-For information on performance, please refer to [performance.md](https://github.com/sayo-hs/heftia/blob/v0.4.0/benchmark/performance.md).--The library allows the following effects with well-defined semantics:--* Coroutines-* Non-deterministic computations-* `MonadUnliftIO`+Please refer to the [Haddock documentation](https://hackage.haskell.org/package/heftia-0.5.0.0/docs/Control-Monad-Hefty.html) for usage and semantics.+For information on performance, please refer to [performance.md](https://github.com/sayo-hs/heftia/blob/v0.5.0/benchmark/performance.md).  This library is inspired by the paper: * Casper Bach Poulsen and Cas van der Rest. 2023. Hefty Algebras: Modular@@ -24,12 +20,87 @@  Heftia's data structure is an extension of the Freer monad, designed to be theoretically straightforward by eliminating ad-hoc elements. +## Why choose this library over others?+This library is based on algebraic effects. Currently, **none of the practical effect libraries other than this one are "algebraic."** So, why is being *algebraic* important?++For example, algebraic effects are essential for managing coroutines, generators, streaming, concurrency, non-deterministic computations, and more in a highly elegant and concise manner.++Algebraic effects provide a consistent and predictable framework for handling side effects, enhancing modularity and flexibility in your code.+Research in cutting-edge languages like [Koka](https://koka-lang.github.io/koka/doc/index.html), [Eff lang](https://www.eff-lang.org/), and [OCaml 5](https://ocaml.org/manual/effects.html) is advancing the understanding and implementation of algebraic effects, establishing them as **the programming paradigm of the future**.++Heftia extends this by supporting higher-order algebraic effects, allowing for more expressive and modular effect management.+This leads to more maintainable and extensible applications compared to non-algebraic effect libraries, positioning Heftia at **the forefront of modern effect handling techniques**.++Furthermore, **Heftia is functionally a superset of other effect libraries**, especially those based on `ReaderT` over `IO`.+In other words, anything that is possible with other libraries is also possible with this library.+This is because Heftia supports `MonadUnliftIO` in the form of higher-order effects.++**Heftia should be a good substitute for `mtl`, `polysemy`, `fused-effects`, and `freer-simple`.**+Additionally, if performance is not a top priority, it should also be a good alternative for `effectful`.+If performance is particularly important, [`effectful`](https://github.com/haskell-effectful/effectful) would be the best alternative to this library.++## Key Features++* **Correct Semantics for Higher-Order Effects & Continuations**++    This library provides the following features simultaneously, which existing libraries could not support together:++    * Delimited continuations (algebraic effects)+        * Coroutines (non-scoped resumptions)+        * Coroutine-based, composable, and resumable concurrent streams+        * Non-deterministic computations++    * Higher-order effects+        * [`MonadUnliftIO`](https://hackage.haskell.org/package/unliftio)+            * to prevent resource leaks due to runtime exceptions+            * [heftia-effects/Example/UnliftIO/Main.hs](https://github.com/sayo-hs/heftia/blob/v0.5.0/heftia-effects/Example/UnliftIO/Main.hs)+            * [heftia-effects/Example/Stream/Main.hs](https://github.com/sayo-hs/heftia/blob/v0.5.0/heftia-effects/Example/Stream/Main.hs)+        * [`Provider`](https://hackage.haskell.org/package/effectful-core-2.5.0.0/docs/Effectful-Provider.html) a.k.a. [`Scoped`](https://hackage.haskell.org/package/polysemy-1.9.2.0/docs/Polysemy-Scoped.html)+            * to prevent [resource handles from leaking out of scopes](https://h2.jaguarpaw.co.uk/posts/bluefin-prevents-handles-leaking/)+            * [Control.Monad.Hefty.Concurrent.Subprocess](https://hackage.haskell.org/package/heftia-effects-0.5.0.0/docs/Control-Monad-Hefty-Concurrent-Subprocess.html)+            * [heftia-effects/Example/Subprocess/Main.hs](https://github.com/sayo-hs/heftia/blob/v0.5.0/heftia-effects/Example/Subprocess/Main.hs)+            * [heftia-effects/Example/FileSystemProvider/Main.hs](https://github.com/sayo-hs/heftia/blob/v0.5.0/heftia-effects/Example/FileSystemProvider/Main.hs)+        * [Applicative-style Parallelism](https://medium.com/@PerrottaFrancisco/learning-cats-effects-parallel-execution-f617f883e390)+            * like `cats-effect` in Scala+            * [Data.Effect.Concurrent.Parallel](https://hackage.haskell.org/package/data-effects-0.3.0.1/docs/Data-Effect-Concurrent-Parallel.html)+            * [Control.Monad.Hefty.Concurrent.Parallel](https://hackage.haskell.org/package/heftia-effects-0.5.0.0/docs/Control-Monad-Hefty-Concurrent-Parallel.html)+            * [heftia-effects/test/Test/Concurrent.hs](https://github.com/sayo-hs/heftia/blob/v0.5.0/heftia-effects/test/Test/Concurrent.hs)++    All of these interact through a simple, consistent, and predictable semantics based on algebraic effects.++* **Easy and Concise Implementation for Custom Effect Interpreters**++    As you can see from the implementations of basic effect interpreters such as [State](https://hackage.haskell.org/package/heftia-effects-0.5.0.0/docs/src/Control.Monad.Hefty.State.html#runState), [Throw/Catch](https://hackage.haskell.org/package/heftia-effects-0.5.0.0/docs/src/Control.Monad.Hefty.Except.html#runThrow), [Writer](https://hackage.haskell.org/package/heftia-effects-0.5.0.0/docs/src/Control.Monad.Hefty.Writer.html#runTell), [NonDet](https://hackage.haskell.org/package/heftia-effects-0.5.0.0/docs/src/Control.Monad.Hefty.NonDet.html#runNonDet), and [Coroutine](https://hackage.haskell.org/package/heftia-effects-0.5.0.0/docs/src/Control.Monad.Hefty.Coroutine.html#runCoroutine), they can be implemented in just a few lines, or even a single line. Even for effects like NonDet and Coroutine, which involve continuations and might seem difficult to implement at first glance, this is exactly how simple it can be. This is the power of algebraic effects. Users can quickly define experimental and innovative custom effects using continuations.++* **Standard and Reasonable Performance**++    It operates at a speed positioned roughly in the middle between faster libraries (like `effectful` or `eveff`) and relatively slower ones (like `polysemy` or `fused-effects`): [performance.md](https://github.com/sayo-hs/heftia/blob/v0.5.0/benchmark/performance.md).++* **Purity**++    * Does not depend on the IO monad and can use any monad as the base monad.+    * Semantics are isolated from the IO monad, meaning that aspects like asynchronous exceptions and threads do not affect the behavior of effects.+    * The constructors of the `Eff` monad are [exposed](https://hackage.haskell.org/package/heftia-0.5.0.0/docs/Control-Monad-Hefty.html#t:Eff), and users can manipulate them directly without any safety concerns. Still, the semantics remain intact.+    * These are in contrast to libraries like `effectful` and `eff`, making this library more **Haskell-ish and purely functional**.++## Downsides++This library has notable semantic differences, particularly compared to libraries like `effectful`, `polysemy`, and `fused-effects`.+The semantics of this library are almost equivalent to those of `freer-simple` and are also similar to Alexis King's `eff` library.+This type of semantics is often referred to as *continuation-based semantics*.+Additionally, unlike recent libraries such as `effectful`, which have an IO-fused effect system, the semantics of this library are separated from IO.+Due to these differences, people who are already familiar with the semantics of other major libraries may find it challenging to transition to this library due to the mental model differences.++For those who have not used an extensible effects library in Haskell before, this should not be a problem.+Particularly, if you are already somewhat familiar with the semantics of algebraic effects through languages like `koka` or `eff-lang`,+you likely already have the mental model needed for this library, and everything should go smoothly.+ ## Status  This library is currently in the beta stage. There may be significant changes and potential bugs. -**We are looking forward to your feedback!**+**I am looking forward to your feedback!**  ## Getting Started 1.@@ -87,107 +158,175 @@     Could not deduce ‘GHC.TypeNats.KnownNat (1 GHC.TypeNats.+ ...)’  The supported versions are GHC 9.4.1 and later.-This library has been tested with GHC 9.8.2 and 9.4.1.--## Getting Started+This library has been tested with GHC 9.4.1, 9.6.6 and 9.8.2.  ## Example -Compared to existing Effect System libraries in Haskell that handle higher-order effects, this-library's approach allows for a more effortless and flexible handling of higher-order effects. Here-are some examples:--### Extracting Multi-shot Delimited Continuations+### Coroutine-based Composable Concurrent Stream (since v0.5) -In handling higher-order effects, it's easy to work with **multi-shot delimited continuations**.-For more details, please refer to-the [example code](https://github.com/sayo-hs/heftia/blob/v0.4.0/heftia-effects/Example/Continuation/Main.hs).+Below is an example of using concurrent streams (pipes). -### Two interpretations of the `censor` effect for Writer+```haskell+{-# OPTIONS_GHC -fplugin GHC.TypeLits.KnownNat.Solver #-} -Let's consider the following Writer effectful program:+import Control.Monad.Hefty+import Control.Monad.Hefty.Concurrent.Stream+import Control.Monad.Hefty.Concurrent.Timer+import Control.Monad.Hefty.Except+import Control.Monad.Hefty.Unlift+import Control.Arrow ((>>>))+import Control.Monad (forever, void, when)+import Data.Foldable (for_)+import UnliftIO (bracket_) -```hs-hello :: (Tell String <: m, Monad m) => m ()-hello = do-    tell "Hello"-    tell " world!"+-- | Generates a sequence of 1, 2, 3, 4 at 0.5-second intervals.+produce :: (Output Int <| ef, Timer <| ef) => Eff '[] ef ()+produce = void . runThrow @() $+    for_ [1 ..] \(i :: Int) -> do+        when (i == 5) $ throw ()+        output i+        sleep 0.5 -censorHello :: (Tell String <: m, WriterH String <<: m, Monad m) => m ()-censorHello =-    censor-        ( \s ->-            if s == "Hello" then-                "Goodbye"-            else if s == "Hello world!" then-                "Hello world!!"-            else-                s-        )-        hello-```+-- | Receives the sequence at 0.5-second intervals and prints it.+consume :: (Input Int <| ef, Timer <| ef, IO <| ef) => Eff eh ef ()+consume = forever do+    liftIO . print =<< input @Int+    sleep 0.5 -For `censorHello`, should the final written string be `"Goodbye world!"` (Pre-applying behavior) ?-Or should it be `"Hello world!!"` (Post-applying behavior) ?-With Heftia, **you can freely choose either behavior depending on which higher-order effect interpreter (which we call an elaborator) you use**.+-- | Transforms by receiving the sequence as input at 0.5-second intervals,+--   adds 100, and outputs it.+plus100 :: (Input Int <| ef, Output Int <| ef, Timer <| ef, IO <| ef) => Eff eh ef ()+plus100 = forever do+    i <- input @Int+    let o = i + 100+    liftIO $ putStrLn $ "Transform " <> show i <> " to " <> show o+    output o+    sleep 0.5 -```hs main :: IO ()-main = runEff do-    (sPre, _) <--        runTell-            . runWriterHPre @String-            $ censorHello--    (sPost, _) <--        runTell-            . runWriterHPost @String-            $ censorHello+main = runUnliftIO . runTimerIO $ do+    let produceWithBracket =+            bracket_+                (liftIO $ putStrLn "Start")+                (liftIO $ putStrLn "End")+                (raiseAllH produce) -    liftIO $ putStrLn $ "Pre-applying: " <> sPre-    liftIO $ putStrLn $ "Post-applying: " <> sPost+    runMachineryIO_ $+        Unit @() @Int do+            produceWithBracket+            produceWithBracket+            >>> Unit @Int @Int plus100+            >>> Unit @Int @() consume ``` -Using the `elabWriterPre` elaborator, you'll get "Goodbye world!", whereas with the `elabWriterPost` elaborator, you'll get "Hello world!!". ```-Pre-applying: Goodbye world!-Post-applying: Hello world!!+>>> main+Start+Transform 1 to 101+101+Transform 2 to 102+102+Transform 3 to 103+103+Transform 4 to 104+104+End+Start+Transform 1 to 101+101+Transform 2 to 102+102+Transform 3 to 103+103+Transform 4 to 104+104+End ``` -For more details, please refer to the [complete code](https://github.com/sayo-hs/heftia/blob/v0.4.0/heftia-effects/Example/Writer/Main.hs) and the [implementation of the elaborator](https://github.com/sayo-hs/heftia/blob/v0.4.0/heftia-effects/src/Control/Effect/Interpreter/Heftia/Writer.hs).+* Each function (machine unit) `produce`, `consume`, and `plus100` operates with input/output at 0.5-second intervals, but note that the composed stream also maintains operation intervals at 0.5 seconds (not 1.5 seconds!). This means that each unit operates concurrently based on threads. -### Semantics Zoo-To run the [SemanticsZoo example](https://github.com/sayo-hs/heftia/blob/v0.4.0/heftia-effects/Example/SemanticsZoo/Main.hs):-```console-$ git clone https://github.com/sayo-hs/heftia-$ cd heftia/heftia-effects-$ cabal run exe:SemanticsZoo-...-# State & Except-( evalState . runThrow . runCatch $ action ) = Right True-( runThrow . evalState . runCatch $ action ) = Right True+* `End` is displayed just after the first sequence ends and before the second sequence starts. This demonstrates that the `bracket_` function based on `MonadUnliftIO` for safe resource release works in such a way that resources are released immediately at the correct timing—even if the stream is still in progress—rather than waiting until the entire stream (including the second sequence) has completed. Existing stream libraries like [`pipes`](https://hackage.haskell.org/package/pipes) and [`conduit`](https://hackage.haskell.org/package/conduit) have the issue that immediate resource release like this is not possible. This problem was first addressed by the effect system library [`bluefin`](https://github.com/tomjaguarpaw/bluefin). For more details, please refer to [Bluefin streams finalize promptly](https://h2.jaguarpaw.co.uk/posts/bluefin-streams-finalize-promptly/). -# NonDet & Except-( runNonDet . runThrow . runCatch . runChooseH $ action1 ) = [Right True,Right False]-( runThrow . runNonDet . runCatch . runChooseH $ action1 ) = Right [True,False]-( runNonDet . runThrow . runCatch . runChooseH $ action2 ) = [Right False,Right True]-( runThrow . runNonDet . runCatch . runChooseH $ action2 ) = Right [False,True]+The complete code example can be found at [heftia-effects/Example/Stream/Main.hs](https://github.com/sayo-hs/heftia/blob/v0.5.0/heftia-effects/Example/Stream/Main.hs). -# NonDet & Writer-( runNonDet . runTell . runWriterH . runChooseH $ action ) = [(3,(3,True)),(4,(4,False))]-( runTell . runNonDet . runWriterH . runChooseH $ action ) = (6,[(3,True),(4,False)])+### Aggregating File Sizes Using Non-Deterministic Computation -# https://github.com/hasura/eff/issues/12-interpret SomeEff then runCatch : ( runThrow . runCatch . runSomeEff $ action ) = Right "caught"-runCatch then interpret SomeEff : ( runThrow . runSomeEff . runCatch $ action ) = Left "not caught"+The following is an extract of the main parts from an example of non-deterministic computation. For the full code, please refer to [heftia-effects/Example/NonDet/Main.hs](https://github.com/sayo-hs/heftia/blob/v0.5.0/heftia-effects/Example/NonDet/Main.hs). -[Note] All other permutations will cause type errors.-$+```haskell+-- | Aggregate the sizes of all files under the given path+totalFileSize+    :: (Choose <| ef, Empty <| ef, FileSystem <| ef, Throw NotADir <| ef, IO <| ef)+    => FilePath+    -> Eff '[] ef (Sum Integer)+totalFileSize path = do+    entities :: [FilePath] <- listDirectory path & joinEither++    -- Non-deterministically *pick* one item from the list+    entity :: FilePath <- choice entities++    let path' = path </> entity++    liftIO $ putStrLn $ "Found " <> path'++    getFileSize path' >>= \case+        Right size -> do+            liftIO $ putStrLn $ " ... " <> show size <> " bytes"+            pure $ Sum size+        Left NotAFile -> do+            totalFileSize path'++main :: IO ()+main = runEff+    . runThrowIO @EntryNotFound+    . runThrowIO @NotADir+    . runDummyFS exampleRoot+    $ do+        total <- runNonDetMonoid pure (totalFileSize ".")+        liftIO $ print total++-- | Effect for file system operations+data FileSystem a where+    ListDirectory :: FilePath -> FileSystem (Either NotADir [FilePath])+    GetFileSize :: FilePath -> FileSystem (Either NotAFile Integer)++{- |+Interpreter for the FileSystem effect that virtualizes the file system in memory+based on a given FSTree, instead of performing actual IO.+-}+runDummyFS+    :: (Throw EntryNotFound <| ef, Throw NotADir <| ef)+    => FSTree+    -> Eff eh (FileSystem ': ef) ~> Eff eh ef+runDummyFS root = interpret \case+    ListDirectory path ->+        lookupFS path root <&> \case+            Dir entries -> Right $ Map.keys entries+            File _ -> Left NotADir+    GetFileSize path ->+        lookupFS path root <&> \case+            File size -> Right size+            Dir _ -> Left NotAFile ``` +```+>>> main+Found ./README.md+ ... 4000 bytes+Found ./src+Found ./src/Bar.hs+ ... 1000 bytes+Found ./src/Foo.hs+ ... 2000 bytes+Found ./test+Found ./test/Baz.hs+ ... 3000 bytes+Sum {getSum = 10000}+```+ ## Documentation-A detailed explanation of usage and semantics is available in [Haddock](https://hackage.haskell.org/package/heftia-0.4.0.0/docs/Control-Monad-Hefty.html).-The example codes are located in the [heftia-effects/Example/](https://github.com/sayo-hs/heftia/tree/v0.4.0/heftia-effects/Example) directory.+A detailed explanation of usage and semantics is available in [Haddock](https://hackage.haskell.org/package/heftia-0.5.0.0/docs/Control-Monad-Hefty.html).+The example codes are located in the [heftia-effects/Example/](https://github.com/sayo-hs/heftia/tree/v0.5.0/heftia-effects/Example) directory. Also, the following *HeftWorld* example (outdated): https://github.com/sayo-hs/HeftWorld  About the internal *elaboration* mechanism: https://sayo-hs.github.io/jekyll/update/2024/09/04/how-the-heftia-extensible-effects-library-works.html@@ -214,20 +353,21 @@ | `freer-simple`      | No                   | Multi-shot             | Yes           | Yes                               | Yes                      | Algebraic Effects                | | `polysemy`          | Yes                  | No                     | Yes           | Yes                               | Yes                      | Weaving-based (functorial state) | | `effectful`         | Yes                  | No                     | Yes           | No (based on the `IO` monad)      | Yes                      | IO-fused                         |+| `bluefin`           | Yes                  | No                     | Yes           | No (based on the `IO` monad)      | Yes                      | IO-fused                         | | `eff`               | Yes                  | Multi-shot             | Yes           | No (based on the `IO` monad)      | Yes                      | Algebraic Effects & IO-fused [^6]| | `speff`             | Yes                  | Multi-shot (restriction: [^4]) | Yes   | No (based on the `IO` monad)      | Yes                      | Algebraic Effects & IO-fused     | | `in-other-words`    | Yes                  | Multi-shot?            | Yes           | Yes                               | No?                      | Carrier dependent                | | `mtl`               | Yes                  | Multi-shot (`ContT`)   | Yes           | Yes                               | No                       | Carrier dependent                | | `fused-effects`     | Yes                  | No?                    | Yes           | Yes                               | No                       | Carrier dependent & Weaving-based (functorial state) | | Koka-lang           | No                   | Multi-shot             | Yes           | No (language built-in)            | Yes                      | Algebraic Effects                |-| OCaml-lang 5        | ?                    | One-shot               | No [^3]       | No (language built-in)            | ?                        | Algebraic Effects?               |+| Eff-lang            | No                   | Multi-shot             | Yes           | No (language built-in)            | Yes                      | Algebraic Effects                |+| OCaml-lang 5        | ?                    | One-shot               | No [^3]       | No (language built-in)            | ?                        | Algebraic Effects                |  [^3]: Effects do not appear in the type signature and can potentially cause unhandled errors at runtime [^4]: Scoped Resumption only. e.g. Coroutines are not supported.-[^5]: https://github.com/sayo-hs/heftia/issues/12 [^6]: https://github.com/hasura/eff/issues/12 -Heftia can simply be described as a higher-order version of freer-simple.+Heftia can simply be described as a higher-order version of `freer-simple`. This is indeed true in terms of its internal mechanisms as well.  Additionally, this library provides a consistent algebraic effects semantics that is independent of carriers and effects.@@ -245,45 +385,53 @@ Overall, the performance of this library is positioned roughly in the middle between the fast (`effectful`, `eveff`, etc.) and slow (`polysemy`, `fused-effects`, etc.) libraries, and can be considered average. In all benchmarks, the speed is nearly equivalent to `freer-simple`, only slightly slower. -For more details, please refer to [performance.md](https://github.com/sayo-hs/heftia/blob/v0.4.0/benchmark/performance.md).+For more details, please refer to [performance.md](https://github.com/sayo-hs/heftia/blob/v0.5.0/benchmark/performance.md). -### Compatibility with other libraries+### Interoperability with other libraries -#### About mtl+#### About `mtl` * Since the representation of effectful programs in Heftia is simply a monad (`Eff`), it can be used as the base monad for transformers.     This means you can stack any transformer on top of it.  * The `Eff` monad is an instance of `MonadIO`, `MonadError`, `MonadRWS`, `MonadUnliftIO`, `Alternative`, etc., and these behave as the senders for the embedded `IO` or the effect GADTs defined in [data-effects](https://github.com/sayo-hs/data-effects). +#### About `effectful`++* In Heftia, since any monad can be used as the base monad of `Eff`, by setting the `Eff` monad from `effectful` as the base monad of Heftia, you can stack any effect in Heftia on top of `effectful`. In other words, the `Eff` of `Heftia` itself can be used like a monad transformer. This is not limited to `effectful`.++* By using `Control.Monad.Hefty.Unlift.runUnliftIO` instead of `Control.Monad.Hefty.runEff`, you can inherit and use the `MonadUnliftIO` functionality of `effectful`'s `Eff` as a higher-order `UnliftIO` effect within Heftia.+ #### Representation of effects * Heftia relies on [data-effects](https://hackage.haskell.org/package/data-effects) for the definitions of standard effects such as `Reader`, `Writer`, and `State`.  * It is generally recommended to use effects defined with automatic derivation provided by [data-effects-th](https://hackage.haskell.org/package/data-effects-th). -* The representation of first-order effects is compatible with freer-simple.-    Therefore, effects defined for freer-simple can be used as is in this library.+* The representation of first-order effects is compatible with `freer-simple`.+    Therefore, effects defined for `freer-simple` can be used as is in this library.     However, to avoid confusion between redundantly defined effects,     it is recommended to use the effects defined in `data-effects`. -* GADTs for higher-order effects are formally similar to Polysemy and fused-effects,+* GADTs for higher-order effects are formally similar to `polysemy` and `fused-effects`,     but they need to be instances of the [`HFunctor`](https://hackage.haskell.org/package/compdata-0.13.1/docs/Data-Comp-Multi-HFunctor.html#t:HFunctor) type class.     While it's not impossible to manually derive `HFunctor` for effect types based on these libraries and use them,     it's inconvenient, so it's better to use `data-effects`.-    Also, it is not compatible with Effectful and eff.+    Also, it is not compatible with `effectful` and `eff`.  ## Future Plans+* Increase effects and nurture the ecosystem+    * file system, POSIX, and so on...+* Write practical software using Heftia * Support for Applicative effects-* Completing lacking definitions such as-    * interpreters for the `Accum` and others effects+* (Support for [Linear](https://hackage.haskell.org/package/linear-base) effects?)  ## License-The license is MPL 2.0. Please refer to the [NOTICE](https://github.com/sayo-hs/heftia/blob/v0.4.0/NOTICE).+The license is MPL 2.0. Please refer to the [NOTICE](https://github.com/sayo-hs/heftia/blob/v0.5.0/NOTICE). Additionally, the code from `freer-simple` has been modified and used internally within this library. Therefore, some modules are licensed under both `MPL-2.0 AND BSD-3-Clause`. For details on licenses and copyrights, please refer to the module's Haddock documentation.  ## Your contributions are welcome!-Please see [CONTRIBUTING.md](https://github.com/sayo-hs/heftia/blob/v0.4.0/CONTRIBUTING.md).+Please see [CONTRIBUTING.md](https://github.com/sayo-hs/heftia/blob/v0.5.0/CONTRIBUTING.md).  ## Acknowledgements, citations, and related work The following is a non-exhaustive list of people and works that have had a significant impact, directly or indirectly, on Heftia’s design and implementation:@@ -294,6 +442,7 @@ - Sandy Maguire and other contributors — [`polysemy`][gh:polysemy] - Alexis King and other contributors — [`freer-simple`][gh:freer-simple], [`eff`][gh:eff] - Casper Bach Poulsen and Cas van der Rest — [Hefty Algebras: Modular Elaboration of Higher-Order Algebraic Effects][casper:hefty]+- Tom Ellis — [Bluefin streams finalize promptly][tom:bluefin-streams]  [gh:fused-effects]: https://github.com/fused-effects/fused-effects [gh:polysemy]: https://github.com/polysemy-research/polysemy@@ -302,3 +451,4 @@ [casper:hefty]: https://dl.acm.org/doi/10.1145/3571255 [gh:freer-simple]: https://github.com/lexi-lambda/freer-simple [gh:eff]: https://github.com/lexi-lambda/eff+[tom:bluefin-streams]: https://h2.jaguarpaw.co.uk/posts/bluefin-streams-finalize-promptly/

@@ -1,7 +1,7 @@ -- SPDX-License-Identifier: BSD-3-Clause -- (c) 2022 Xy Ren; 2024 Sayo Koyoneda --- Benchmarking scoped effects #1: Catching errors+-- Benchmarking higher-order effects #1: Catching errors  module BenchCatch where @@ -13,8 +13,6 @@ import Control.Monad.Hefty.Reader qualified as H import Control.Monad.Identity qualified as M import Control.Monad.Reader qualified as M-import Data.Effect.Except qualified as H-import Data.Effect.Reader qualified as H import Effectful qualified as EL import Effectful.Error.Dynamic qualified as EL import Effectful.Reader.Dynamic qualified as EL

@@ -12,7 +12,6 @@ import Control.Monad.Hefty.Reader qualified as H import Control.Mp.Eff qualified as Mp import Control.Mp.Util qualified as Mp-import Data.Effect.Coroutine qualified as H import "eff" Control.Effect qualified as E  programFreer :: (FS.Member (FS.Yield Int Int) es) => Int -> FS.Eff es [Int]

@@ -17,7 +17,6 @@ import Control.Monad.Identity qualified as M import Control.Monad.Reader qualified as M import Control.Monad.State.Strict qualified as M-import Data.Effect.State qualified as H import Effectful qualified as EL import Effectful.Reader.Dynamic qualified as EL import Effectful.State.Dynamic qualified as EL

@@ -0,0 +1,114 @@+-- SPDX-License-Identifier: BSD-3-Clause+-- (c) 2022 Xy Ren; 2024 Sayo Koyoneda++-- Benchmarking higher-order effects #2: Local environments++module BenchLocal where++import Control.Carrier.Reader qualified as F+import Control.Monad.Hefty qualified as H+import Control.Monad.Hefty.Reader qualified as H+import Effectful qualified as EL+import Effectful.Reader.Dynamic qualified as EL+import Polysemy qualified as P+import Polysemy.Reader qualified as P+import "eff" Control.Effect qualified as E++programHeftia :: (H.Member (H.Ask Int) ef, H.MemberH (H.Local Int) eh) => Int -> H.Eff eh ef Int+programHeftia = \case+    0 -> H.ask+    n -> H.local @Int (+ 1) (programHeftia (n - 1))+{-# NOINLINE programHeftia #-}++localHeftia :: Int -> Int+localHeftia n = H.runPure $ H.runAsk @Int 0 $ H.runLocal @Int $ programHeftia n++localHeftiaDeep0, localHeftiaDeep1, localHeftiaDeep2, localHeftiaDeep3, localHeftiaDeep4, localHeftiaDeep5 :: Int -> Int+localHeftiaDeep0 n = H.runPure $ hrun $ hrun $ hrun $ hrun $ hrun $ H.runAsk @Int 0 $ hrun $ hrun $ hrun $ hrun $ hrun $ H.runLocal @Int $ programHeftia n+localHeftiaDeep1 n = H.runPure $ hrun $ hrun $ hrun $ hrun $ hrun $ H.runAsk @Int 0 $ hrun $ hrun $ hrun $ hrun $ H.runLocal @Int $ hrun $ programHeftia n+localHeftiaDeep2 n = H.runPure $ hrun $ hrun $ hrun $ hrun $ hrun $ H.runAsk @Int 0 $ hrun $ hrun $ hrun $ H.runLocal @Int $ hrun $ hrun $ programHeftia n+localHeftiaDeep3 n = H.runPure $ hrun $ hrun $ hrun $ hrun $ hrun $ H.runAsk @Int 0 $ hrun $ hrun $ H.runLocal @Int $ hrun $ hrun $ hrun $ programHeftia n+localHeftiaDeep4 n = H.runPure $ hrun $ hrun $ hrun $ hrun $ hrun $ H.runAsk @Int 0 $ hrun $ H.runLocal @Int $ hrun $ hrun $ hrun $ hrun $ programHeftia n+localHeftiaDeep5 n = H.runPure $ hrun $ hrun $ hrun $ hrun $ hrun $ H.runAsk @Int 0 $ H.runLocal @Int $ hrun $ hrun $ hrun $ hrun $ hrun $ programHeftia n++hrun :: H.Eff eh (H.Ask () ': ef) a -> H.Eff eh ef a+hrun = H.runAsk ()++programSem :: (P.Reader Int `P.Member` es) => Int -> P.Sem es Int+programSem = \case+    0 -> P.ask+    n -> P.local @Int (+ 1) (programSem (n - 1))+{-# NOINLINE programSem #-}++localSem :: Int -> Int+localSem n = P.run $ P.runReader @Int 0 $ programSem n++localSemDeep :: Int -> Int+localSemDeep n = P.run $ run $ run $ run $ run $ run $ P.runReader @Int 0 $ run $ run $ run $ run $ run $ programSem n+  where+    run = P.runReader ()++programFused :: (F.Has (F.Reader Int) sig m) => Int -> m Int+programFused = \case+    0 -> F.ask+    n -> F.local @Int (+ 1) (programFused (n - 1))+{-# NOINLINE programFused #-}++localFused :: Int -> Int+localFused n = F.run $ F.runReader @Int 0 $ programFused n++localFusedDeep :: Int -> Int+localFusedDeep n = F.run $ run $ run $ run $ run $ run $ F.runReader @Int 0 $ run $ run $ run $ run $ run $ programFused n+  where+    run = F.runReader ()++programEffectful :: (EL.Reader Int EL.:> es) => Int -> EL.Eff es Int+programEffectful = \case+    0 -> EL.ask+    n -> EL.local @Int (+ 1) (programEffectful (n - 1))+{-# NOINLINE programEffectful #-}++localEffectful :: Int -> Int+localEffectful n = EL.runPureEff $ EL.runReader @Int 0 $ programEffectful n++localEffectfulDeep :: Int -> Int+localEffectfulDeep n =+    EL.runPureEff $ run $ run $ run $ run $ run $ EL.runReader @Int 0 $ run $ run $ run $ run $ run $ programEffectful n+  where+    run = EL.runReader ()++programEff :: (E.Reader Int E.:< es) => Int -> E.Eff es Int+programEff = \case+    0 -> E.ask+    n -> E.local @Int (+ 1) (programEff (n - 1))+{-# NOINLINE programEff #-}++localEff :: Int -> Int+localEff n = E.run $ E.runReader @Int 0 $ programEff n++localEffDeep :: Int -> Int+localEffDeep n = E.run $ run $ run $ run $ run $ run $ E.runReader @Int 0 $ run $ run $ run $ run $ run $ programEff n+  where+    run = E.runReader ()++{-+The MTL case is disabled because of conflicting functional dependencies.++When using something other than Reader to build up the stack, it is considered+that the performance degradation caused by the pure stack factor cannot be+measured.++programMtl :: (M.MonadReader Int m) => Int -> m Int+programMtl = \case+    0 -> M.ask+    n -> M.local (+ 1) (programMtl (n - 1))+{-# NOINLINE programMtl #-}++localMtl :: Int -> Int+localMtl n = M.runReader 0 $ programMtl n++localMtlDeep :: Int -> Int+localMtlDeep n = M.runIdentity $ run $ run $ run $ run $ run $ M.runReader 0 $ run $ run $ run $ run $ run $ programMtl n+  where+    run = (`M.runReaderT` ())+-}

@@ -22,7 +22,6 @@ import Control.Monad.Reader qualified as M import Control.Mp.Eff qualified as Mp import Control.Mp.Util qualified as Mp-import Data.Effect.NonDet qualified as H import "eff" Control.Effect qualified as EF  programFreer :: (FS.Member FS.NonDet es) => Int -> FS.Eff es (Int, Int, Int)

@@ -6,6 +6,7 @@ import BenchCatch import BenchCoroutine import BenchCountdown+import BenchLocal import BenchPyth import Data.Functor ((<&>)) import Test.Tasty.Bench@@ -66,6 +67,34 @@                     , bench "effectful.5+5" $ nf catchEffectfulDeep x                     , -- , bench "eff.5+5" $ nf catchEffDeep x                       bench "mtl.5+5" $ nf catchMtlDeep x+                    ]+        , bgroup "local.shallow" $+            [10000] <&> \x ->+                bgroup+                    (show x)+                    [ bench "heftia" $ nf localHeftia x+                    , bench "polysemy" $ nf localSem x+                    , bench "fused" $ nf localFused x+                    , bench "effectful" $ nf localEffectful x+                    -- , bench "eff" $ nf localEff x+                    -- `eff` is x500 slow in this case, so it is excluded because it makes the graph hard to read.+                    --  bench "mtl" $ nf localMtl x+                    ]+        , bgroup "local.deep" $+            [10000] <&> \x ->+                bgroup+                    (show x)+                    [ bench "heftia.5+5+0" $ nf localHeftiaDeep0 x+                    , bench "heftia.5+4+1" $ nf localHeftiaDeep1 x+                    , bench "heftia.5+3+2" $ nf localHeftiaDeep2 x+                    , bench "heftia.5+2+3" $ nf localHeftiaDeep3 x+                    , bench "heftia.5+1+4" $ nf localHeftiaDeep4 x+                    , bench "heftia.5+0+5" $ nf localHeftiaDeep5 x+                    , bench "polysemy.5+5" $ nf localSemDeep x+                    , bench "fused.5+5" $ nf localFusedDeep x+                    , bench "effectful.5+5" $ nf localEffectfulDeep x+                    --  bench "eff.5+5" $ nf localEffDeep x+                    --  bench "mtl.5+5" $ nf localMtlDeep x                     ]         , bgroup "nondet.shallow" $             [32] <&> \x ->

@@ -1,9 +1,9 @@ cabal-version:      2.4 name:               heftia-effects-version:            0.4.0.1+version:            0.5.0.0  -- A short (one-line) description of the package.-synopsis: higher-order effects done right+synopsis: higher-order algebraic effects done right  -- A longer description of the package. description:@@ -30,12 +30,13 @@  tested-with:     GHC == 9.8.2+    GHC == 9.6.6     GHC == 9.4.1  source-repository head     type: git     location: https://github.com/sayo-hs/heftia-    tag: v0.4.0.1+    tag: v0.5.0     subdir: heftia-effects  common common-base@@ -55,13 +56,17 @@      build-depends:         base >= 4.17 && < 4.21,-        data-effects ^>= 0.2,-        heftia ^>= 0.4,+        data-effects ^>= 0.3.0.1,+        heftia ^>= 0.5,         time >= 1.11.1 && < 1.15,         unliftio ^>= 0.2,         unbounded-delays ^>= 0.1.1,         ghc-typelits-knownnat ^>= 0.7,         containers > 0.6.5 && < 0.8,+        co-log-core ^>= 0.3.2,+        process ^>= 1.6.15,+        bytestring >= 0.11.1 && < 0.13,+        text >= 1.2.5 && < 2.2,      ghc-options: -Wall @@ -84,7 +89,11 @@         Control.Monad.Hefty.KVStore         Control.Monad.Hefty.Fresh         Control.Monad.Hefty.Fail+        Control.Monad.Hefty.Concurrent.Parallel+        Control.Monad.Hefty.Concurrent.Stream         Control.Monad.Hefty.Concurrent.Timer+        Control.Monad.Hefty.Concurrent.Subprocess+        Control.Monad.Hefty.Log      reexported-modules:         Control.Monad.Hefty,@@ -115,7 +124,9 @@         Data.Effect.KVStore,         Data.Effect.Fresh,         Data.Effect.Fail,+        Data.Effect.Concurrent.Parallel,         Data.Effect.Concurrent.Timer,+        Data.Effect.Log,      -- Modules included in this executable, other than Main.     -- other-modules:@@ -135,6 +146,7 @@         Test.Writer         Test.Pyth         Test.Coroutine+        Test.Concurrent      hs-source-dirs: test @@ -185,14 +197,14 @@     build-depends:         heftia-effects, -executable Continuation2+executable ShiftReset     import: common-base      main-is: Main.hs-    hs-source-dirs: Example/Continuation2+    hs-source-dirs: Example/ShiftReset     build-depends:         heftia-effects,-        extra ^>= 1.7.14,+        extra >= 1.7.14 && < 1.9,  executable Writer     import: common-base@@ -218,6 +230,40 @@     build-depends:         heftia-effects, +executable Subprocess+    import: common-base++    main-is: Main.hs+    hs-source-dirs: Example/Subprocess+    build-depends:+        heftia-effects,++executable UnliftIO+    import: common-base++    main-is: Main.hs+    hs-source-dirs: Example/UnliftIO+    build-depends:+        heftia-effects,++executable Stream+    import: common-base++    main-is: Main.hs+    hs-source-dirs: Example/Stream+    build-depends:+        heftia-effects,++executable NonDet+    import: common-base++    main-is: Main.hs+    hs-source-dirs: Example/NonDet+    build-depends:+        heftia-effects,+        text,+        filepath >= 1.4.2.2 && < 1.6,+ benchmark heftia-bench     import: common-base @@ -232,20 +278,22 @@         freer-simple ^>= 1.2,         polysemy ^>= 1.9,         fused-effects ^>= 1.1,-        effectful ^>= 2.3,+        effectful >= 2.3 && < 2.6,         eveff ^>= 1.0,         mtl >= 2.2 && < 2.4,         logict >= 0.7.0.3 && < 0.9,         tasty-bench >= 0.3 && < 0.5,-        eff,         mpeff, +    if impl(ghc >= 9.6) && impl(ghc < 9.10)+       build-depends: eff+     default-extensions:         PackageImports      other-modules:         BenchCountdown         BenchCatch-        -- BenchLocal+        BenchLocal         BenchCoroutine         BenchPyth

@@ -0,0 +1,142 @@+{-# LANGUAGE CPP #-}+{-# OPTIONS_GHC -fplugin GHC.TypeLits.KnownNat.Solver #-}++-- SPDX-License-Identifier: MPL-2.0++{- |+Copyright   :  (c) 2024 Sayo Koyoneda+License     :  MPL-2.0 (see the LICENSE file)+Maintainer  :  ymdfield@outlook.jp++Interpreters for the [Parallel]("Data.Effect.Concurrent.Parallel") effects.+-}+module Control.Monad.Hefty.Concurrent.Parallel (+    module Control.Monad.Hefty.Concurrent.Parallel,+    module Data.Effect.Concurrent.Parallel,+    module Data.Effect.Input,+)+where++#if ( __GLASGOW_HASKELL__ < 906 )+import Control.Applicative (liftA2)+#endif+import Control.Monad (forever)+import Control.Monad.Hefty (+    Eff,+    interpret,+    interpretH,+    raiseAllH,+    transform,+    type (<<|),+    type (<|),+    type (~>),+    type (~~>),+ )+import Control.Monad.Hefty.Coroutine (inputToYield, runCoroutine)+import Control.Monad.Hefty.Unlift (UnliftIO)+import Data.Effect.Concurrent.Parallel+import Data.Effect.Coroutine (Status (Continue, Done))+import Data.Effect.Input+import Data.Function (fix)+import UnliftIO (+    MonadIO,+    MonadUnliftIO,+    atomically,+    liftIO,+    mask,+    newEmptyTMVarIO,+    putTMVar,+    readTMVar,+    tryReadTMVar,+    uninterruptibleMask_,+    withRunInIO,+ )+import UnliftIO.Concurrent (forkIO, killThread, threadDelay)++runConcurrentIO+    :: (UnliftIO <<| eh, IO <| ef)+    => Eff (Parallel ': Race ': Poll ': eh) (Halt ': ef) ~> Eff eh ef+runConcurrentIO = runHaltIO . runPollIO . runRaceIO . runParallelIO++runParallelIO :: (UnliftIO <<| eh, IO <| ef) => Eff (Parallel ': eh) ef ~> Eff eh ef+runParallelIO = interpretH parallelToIO++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 :: (IO <| ef, UnliftIO <<| eh) => Eff (Poll ': eh) ef ~> Eff eh ef+runPollIO = interpretH pollToIO++runRaceIO :: (IO <| ef, UnliftIO <<| eh) => Eff (Race ': eh) ef ~> Eff eh ef+runRaceIO = interpretH raceToIO++runHaltIO :: (IO <| ef) => Eff eh (Halt ': ef) ~> Eff eh ef+runHaltIO = interpret haltToIO++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)++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'++haltToIO :: (MonadIO m) => Halt ~> m+haltToIO Halt = liftIO $ forever $ threadDelay maxBound++runParallelAsSequential :: Eff (Parallel ': eh) ef ~> Eff eh ef+runParallelAsSequential = interpretH parallelToSequential++parallelToSequential :: Parallel ~~> Eff eh ef+parallelToSequential (LiftP2 f a b) = liftA2 f a b++polling :: (Poll <<| eh) => Eff eh ef a -> Eff '[] (Input (Maybe a) ': ef) r -> Eff eh ef r+polling pollee poller =+    poldl+        ( \case+            Done r -> const $ pure $ Left r+            Continue () k -> fmap Right . raiseAllH . k+        )+        (raiseAllH $ runCoroutine $ transform inputToYield poller)+        pollee++runForAsParallel :: (Parallel <<| eh, Traversable t) => Eff (For t ': eh) ef ~> Eff eh ef+runForAsParallel = interpretH forToParallel

@@ -0,0 +1,301 @@+{-# OPTIONS_GHC -fplugin GHC.TypeLits.KnownNat.Solver #-}++{- |+Copyright   :  (c) 2024 Sayo Koyoneda+License     :  MPL-2.0 (see the LICENSE file)+Maintainer  :  ymdfield@outlook.jp++Coroutine-based, composable, and resumable concurrent streams.+-}+module Control.Monad.Hefty.Concurrent.Stream (+    module Control.Monad.Hefty.Concurrent.Stream,+    module Control.Monad.Hefty.Input,+    module Control.Monad.Hefty.Output,+)+where++import Control.Arrow (Arrow, ArrowChoice, arr, first, left, (>>>))+import Control.Category (Category)+import Control.Category qualified as C+import Control.Monad (forM_, forever)+import Control.Monad.Hefty (+    Eff,+    bundleN,+    interpret,+    interpretBy,+    nil,+    raise,+    raiseAllH,+    reinterpret,+    unkey,+    (!+),+    (&),+    type (<<|),+    type (<|),+    type (~>),+ )+import Control.Monad.Hefty.Concurrent.Parallel (Parallel, liftP2)+import Control.Monad.Hefty.Input+import Control.Monad.Hefty.Output+import Control.Monad.Hefty.State (State, evalState, evalStateIORef, get'', put'')+import Data.Effect.Unlift (UnliftIO, withRunInIO)+import Data.Function (fix)+import Data.Sequence (Seq ((:|>)))+import Data.Sequence qualified as Seq+import UnliftIO (+    atomically,+    liftIO,+    mask,+    newEmptyTMVarIO,+    putTMVar,+    readTMVar,+    takeTMVar,+    uninterruptibleMask_,+ )+import UnliftIO.Concurrent (forkIO, killThread)++data Machinery eh ef ans i o where+    Unit+        :: forall i o ans eh ef+         . Eff eh (Input i ': Output o ': ef) ans+        -> Machinery eh ef ans i o+    Connect+        :: forall a b c ans eh ef+         . Machinery eh ef ans a b+        -> Machinery eh ef ans b c+        -> Machinery eh ef ans a c++instance Category (Machinery eh ef ans) where+    id :: forall a. Machinery eh ef ans a a+    id =+        Unit . forever $+            input @a >>= output++    (.) = flip Connect++    {-# INLINE id #-}+    {-# INLINE (.) #-}++instance Arrow (Machinery '[] ef ans) where+    arr (f :: b -> c) =+        Unit . forever $+            input @b >>= output . f++    first+        :: forall b c d+         . Machinery '[] ef ans b c+        -> Machinery '[] ef ans (b, d) (c, d)+    first = \case+        Unit m -> Unit $ evalState (Left Seq.Empty) $ buffering m+        Connect a b -> Connect (first a) (first b)++    {-# INLINE arr #-}+    {-# INLINE first #-}++buffering+    :: forall b c d ans eh ef+     . Eff eh (Input b ': Output c ': ef) ans+    -> Eff eh (State (Either (Seq c) d) ': Input (b, d) ': Output (c, d) ': ef) ans+buffering =+    bundleN @2+        >>> reinterpret+            ( ( \Input -> do+                    (b, d) <- input++                    get'' @"buffer" >>= \case+                        Right _ -> pure ()+                        Left outputQueue -> forM_ outputQueue \c -> output (c, d)++                    put'' @"buffer" $ Right d++                    pure b+              )+                !+ ( \(Output c) ->+                        get'' @"buffer" >>= \case+                            Right d -> output (c, d)+                            Left outputQueue -> put'' @"buffer" $ Left $ outputQueue :|> c+                   )+                !+ nil+            )+        >>> unkey @"buffer"++instance ArrowChoice (Machinery '[] ef ans) where+    left = leftMachinery+    {-# INLINE left #-}++leftMachinery+    :: forall b c d ans eh ef+     . Machinery eh ef ans b c+    -> Machinery eh ef ans (Either b d) (Either c d)+leftMachinery = \case+    Unit m ->+        bundleN @2 m+            & reinterpret+                ( ( \Input -> fix \next ->+                        input @(Either b d) >>= \case+                            Left x -> pure x+                            Right o -> do+                                output @(Either c d) $ Right o+                                next+                  )+                    !+ (\(Output o) -> output @(Either c d) $ Left o)+                    !+ nil+                )+            & Unit+    Connect a b -> Connect (leftMachinery a) (leftMachinery b)++newtype Machine f ans i o = Machine+    {runMachine :: f (MachineStatus f ans i o)}++data MachineStatus f ans i o+    = Terminated ans+    | Waiting (i -> Machine f ans i o)+    | Produced o (Machine f ans i o)++machine :: Eff '[] (Input i ': Output o ': ef) ans -> Machine (Eff eh ef) ans i o+machine =+    bundleN @2+        >>> interpretBy+            (pure . Terminated)+            ( (\Input k -> pure $ Waiting $ Machine . raiseAllH . k)+                !+ (\(Output o) k -> pure $ Produced o $ Machine $ raiseAllH $ k ())+                !+ nil+            )+        >>> raiseAllH+        >>> Machine++runMachinery+    :: forall i o ans eh ef+     . (Parallel <<| eh, Semigroup ans)+    => Machinery '[] ef ans i o+    -> Eff eh ef (MachineStatus (Eff eh ef) ans i o)+runMachinery = runMachineryL . mviewl++runMachineryL+    :: forall i o ans eh ef+     . (Parallel <<| eh, Semigroup ans)+    => MachineryViewL '[] ef ans i o+    -> Eff eh ef (MachineStatus (Eff eh ef) ans i o)+runMachineryL = \case+    MOne m -> runMachine $ machine m+    MCons m ms -> do+        liftP2 (,) (runMachine $ machine m) (runMachinery ms) >>= loop+      where+        loop = \case+            (Terminated ans, Terminated ans') -> pure $ Terminated $ ans <> ans'+            (Produced o k1, Waiting k2) ->+                liftP2 (,) (runMachine k1) (runMachine $ k2 o) >>= loop+            (Waiting k, s) ->+                pure $ Waiting \i -> Machine do+                    s' <- runMachine $ k i+                    loop (s', s)+            (s, Produced o k) ->+                pure $ Produced o $ Machine do+                    s' <- runMachine k+                    loop (s, s')+            (Terminated ans, Waiting _) -> pure $ Terminated ans+            (Produced _ _, Terminated ans) -> pure $ Terminated ans++newtype MachineryIO eh ef ans i o = MachineryIO {unMachineryIO :: Machinery eh ef ans i o}+    deriving newtype (Category)++instance (IO <| ef) => Arrow (MachineryIO eh ef ans) where+    arr (f :: b -> c) =+        MachineryIO . Unit . forever $+            input @b >>= output . f++    first :: forall b c d. MachineryIO eh ef ans b c -> MachineryIO eh ef ans (b, d) (c, d)+    first =+        unMachineryIO+            >>> MachineryIO . \case+                Unit m ->+                    Unit $ evalStateIORef (Left Seq.Empty) $ buffering m+                Connect a b ->+                    Connect+                        (unMachineryIO $ first $ MachineryIO a)+                        (unMachineryIO $ first $ MachineryIO b)++    {-# INLINE arr #-}+    {-# INLINE first #-}++instance (IO <| ef) => ArrowChoice (MachineryIO eh ef ans) where+    left = MachineryIO . leftMachinery . unMachineryIO+    {-# INLINE left #-}++runMachineryIO+    :: forall i o ans eh ef+     . (UnliftIO <<| eh, IO <| ef)+    => Eff eh ef i+    -> (o -> Eff eh ef ())+    -> Machinery eh ef ans i o+    -> Eff eh ef ans+runMachineryIO i o = runMachineryIOL i o . mviewl++runMachineryIOL+    :: forall i o ans eh ef+     . (UnliftIO <<| eh, IO <| ef)+    => Eff eh ef i+    -> (o -> Eff eh ef ())+    -> MachineryViewL eh ef ans i o+    -> Eff eh ef ans+runMachineryIOL i o = \case+    MOne m -> runUnit o m+    MCons a b ->+        withRunInIO \run -> do+            chan <- newEmptyTMVarIO+            ans <- newEmptyTMVarIO+            mask \restore -> do+                let runThread m = forkIO do+                        x <- restore $ run m+                        atomically $ putTMVar ans x++                t1 <- runThread $ runUnit (liftIO . atomically . putTMVar chan) a+                t2 <- runThread $ runMachineryIO (liftIO . atomically $ takeTMVar chan) o b++                atomically (readTMVar ans)+                    <* uninterruptibleMask_ (killThread t1 *> killThread t2)+  where+    runUnit :: (o' -> Eff eh ef ()) -> Eff eh (Input i ': Output o' ': ef) ~> Eff eh ef+    runUnit o' m =+        m+            & interpret (\Input -> raise i)+            & interpret (\(Output x) -> o' x)++runMachineryIO_+    :: forall ans eh ef+     . (UnliftIO <<| eh, IO <| ef)+    => Machinery eh ef ans () ()+    -> Eff eh ef ans+runMachineryIO_ = runMachineryIO (pure ()) (const $ pure ())+{-# INLINE runMachineryIO_ #-}++-- Inspired by https://hackage.haskell.org/package/freer-simple-1.2.1.2/docs/Data-FTCQueue.html++{- |+Left view deconstruction data structure for Machinery Pipeline.++This allows the number of generated threads to be reduced to the number of machine units.+-}+data MachineryViewL eh ef ans i o where+    MOne+        :: forall i o ans eh ef+         . Eff eh (Input i ': Output o ': ef) ans+        -> MachineryViewL eh ef ans i o+    MCons+        :: forall a b c ans eh ef+         . Eff eh (Input a ': Output b ': ef) ans+        -> Machinery eh ef ans b c+        -> MachineryViewL eh ef ans a c++-- | Left view deconstruction for Machinery Pipeline. [average O(1)]+mviewl :: Machinery eh ef ans i o -> MachineryViewL eh ef ans i o+mviewl = \case+    Unit m -> MOne m+    Connect a b -> connect a b+  where+    connect+        :: Machinery eh ef ans a b+        -> Machinery eh ef ans b c+        -> MachineryViewL eh ef ans a c+    connect (Unit m) r = m `MCons` r+    connect (Connect a b) r = connect a (Connect b r)

@@ -0,0 +1,280 @@+{-# LANGUAGE AllowAmbiguousTypes #-}+{-# LANGUAGE TemplateHaskell #-}+{-# OPTIONS_GHC -fplugin GHC.TypeLits.KnownNat.Solver #-}++-- SPDX-License-Identifier: MPL-2.0 AND BSD-3-Clause++{- |+Copyright   :  (c) 2024 Sayo Koyoneda+               (c) The University of Glasgow 2004-2008+License     :  MPL-2.0 (see the LICENSE file) AND BSD-3-Clause+Maintainer  :  ymdfield@outlook.jp++Effects for well-typed subprocess.+-}+module Control.Monad.Hefty.Concurrent.Subprocess (+    module Control.Monad.Hefty.Concurrent.Subprocess,+    module Control.Monad.Hefty.Provider,+    module System.Process,+    module System.Posix.Types,+    module System.IO,+    module System.Exit,+    module Data.ByteString,+)+where++import Control.Applicative ((<|>))+import Control.Concurrent (forkIO)+import Control.Monad (liftM2)+import Control.Monad.Hefty (+    Eff,+    LNop,+    interpret,+    interpretH,+    liftIO,+    makeEffectF,+    (&),+    type (<<|),+    type (<|),+    type (~>),+ )+import Control.Monad.Hefty.Provider+import Control.Monad.Hefty.Unlift (UnliftIO, withRunInIO)+import Data.ByteString (ByteString, hGet, hGetNonBlocking, hPut)+import Data.ByteString qualified as BS+import Data.Function (fix)+import Data.Maybe (fromJust, isNothing)+import System.Exit (ExitCode)+import System.IO (Handle)+import System.Posix.Types (GroupID, UserID)+import System.Process (CmdSpec (RawCommand, ShellCommand))+import System.Process qualified as Raw+import UnliftIO (TMVar, atomically, finally, mask, newEmptyTMVarIO, putTMVar, readTMVar, tryReadTMVar, uninterruptibleMask_)+import UnliftIO.Concurrent (ThreadId, killThread)+import UnliftIO.Process (terminateProcess, waitForProcess)++data Subprocess p a where+    WriteStdin :: ByteString -> Subprocess ('SubprocMode 'Piped o e lp 'Kill) ()+    TryWriteStdin :: ByteString -> Subprocess ('SubprocMode 'Piped o e lp ls) Bool+    ReadStdout :: Subprocess ('SubprocMode i 'Piped e lp ls) ByteString+    ReadStderr :: Subprocess ('SubprocMode i o 'Piped lp ls) ByteString+    PollSubproc :: Subprocess ('SubprocMode i o e lp 'Wait) (Maybe ExitCode)++data SubprocMode = SubprocMode StreamMode StreamMode StreamMode Lifecycle Lifecycle++data StreamMode = Piped | NoPipe+data Lifecycle = Kill | Wait++makeEffectF [''Subprocess]++type SubprocProvider eh ef = Provide SubprocResult CreateProcess (Const2 LNop) Subprocess eh ef++data SubprocResult p a where+    RaceResult :: Either ExitCode a -> SubprocResult ('SubprocMode i o e 'Kill 'Kill) a+    SubprocResult :: ExitCode -> Maybe a -> SubprocResult ('SubprocMode i o e 'Wait 'Kill) a+    ScopeResult :: Maybe ExitCode -> a -> SubprocResult ('SubprocMode i o e 'Kill 'Wait) a+    SubprocScopeResult :: ExitCode -> a -> SubprocResult ('SubprocMode i o e 'Wait 'Wait) a++deriving stock instance (Show a) => Show (SubprocResult p a)+deriving stock instance (Eq a) => Eq (SubprocResult p a)++runSubprocIO :: (UnliftIO <<| eh, IO <| ef) => Eff (SubprocProvider eh ef ': eh) ef ~> Eff eh ef+runSubprocIO =+    runProvider \cp@CreateProcess {subprocLifecycle, scopeLifecycle} m ->+        withRunInIO \run -> do+            (hi, ho, he, ph) <- Raw.createProcess (toRawCreateProcess cp) & liftIO+            procStatus <- newEmptyTMVarIO+            scopeStatus <- newEmptyTMVarIO+            mask \restore -> do+                let+                    runThread :: TMVar a -> IO a -> IO ThreadId+                    runThread var a = forkIO $ atomically . putTMVar var =<< a++                tScope <- runThread scopeStatus $ restore . run $ do+                    m+                        & interpretH \case {}+                        & interpret \case+                            WriteStdin s -> hPut (fromJust hi) s & liftIO+                            TryWriteStdin s -> do+                                stat <- atomically $ tryReadTMVar procStatus+                                if isNothing stat+                                    then do+                                        hPut (fromJust hi) s & liftIO+                                        pure True+                                    else pure False+                            ReadStdout -> hRead (fromJust ho) & liftIO+                            ReadStderr -> hRead (fromJust he) & liftIO+                            PollSubproc -> atomically $ tryReadTMVar procStatus++                _ <- runThread procStatus $ waitForProcess ph++                finally+                    case (subprocLifecycle, scopeLifecycle) of+                        (WaitMode, WaitMode) ->+                            liftM2+                                SubprocScopeResult+                                (atomically $ readTMVar procStatus)+                                (atomically $ readTMVar scopeStatus)+                        (WaitMode, KillMode) -> do+                            exitCode <- atomically $ readTMVar procStatus+                            scopeResult <- atomically $ tryReadTMVar scopeStatus+                            pure $ SubprocResult exitCode scopeResult+                        (KillMode, WaitMode) -> do+                            scopeResult <- atomically $ readTMVar scopeStatus+                            exitCode <- atomically $ tryReadTMVar procStatus+                            pure $ ScopeResult exitCode scopeResult+                        (KillMode, KillMode) ->+                            RaceResult+                                <$> atomically+                                    ( (Left <$> readTMVar procStatus)+                                        <|> (Right <$> readTMVar scopeStatus)+                                    )+                    do+                        uninterruptibleMask_ do+                            terminateProcess ph+                            killThread tScope+                        atomically $ readTMVar procStatus++hRead :: Handle -> IO ByteString+hRead h = flip fix BS.empty \next acc -> do+    s <- hGet h chunkSize+    if BS.null s+        then pure acc+        else next $ acc <> s++chunkSize :: Int+chunkSize = 4096++data CreateProcess p where+    CreateProcess+        :: { cmdspec :: CmdSpec+            -- ^ Executable & arguments, or shell command.  If 'cwd' is 'Nothing', relative paths are resolved with respect to the current working directory.  If 'cwd' is provided, it is implementation-dependent whether relative paths are resolved with respect to 'cwd' or the current working directory, so absolute paths should be used to ensure portability.+           , stdin :: StdStream i+            -- ^ How to determine stdin+           , stdout :: StdStream o+            -- ^ How to determine stdout+           , stderr :: StdStream e+            -- ^ How to determine stderr+           , subprocLifecycle :: LifecycleMode lp+            -- ^ Whether to kill the subprocess or wait when the scope's computation finishes first.+           , scopeLifecycle :: LifecycleMode ls+            -- ^ Whether to cancel the scope's computation or wait when the subprocess finishes first.+           , cwd :: Maybe FilePath+            -- ^ Optional path to the working directory for the new process+           , env :: Maybe [(String, String)]+            -- ^ Optional environment (otherwise inherit from the current process)+           , closeFds :: Bool+            -- ^ Close all file descriptors except stdin, stdout and stderr in the new process (on Windows, only works if std_in, std_out, and std_err are all Inherit). This implementation will call close on every fd from 3 to the maximum of open files, which can be slow for high maximum of open files. XXX verify what happens with fds in nodejs child processes+           , createGroup :: Bool+            -- ^ Create a new process group. On JavaScript this also creates a new session.+           , delegateCtlc :: Bool+            -- ^ Delegate control-C handling. Use this for interactive console processes to let them handle control-C themselves (see below for details).+           , detachConsole :: Bool+            -- ^ Use the windows DETACHED_PROCESS flag when creating the process; does nothing on other platforms.+           , createNewConsole :: Bool+            -- ^ Use the windows CREATE_NEW_CONSOLE flag when creating the process; does nothing on other platforms.+           , newSession :: Bool+            -- ^ Use posix setsid to start the new process in a new session; starts process in a new session on JavaScript; does nothing on other platforms.+           , childGroup :: Maybe GroupID+            -- ^ Use posix setgid to set child process's group id; works for JavaScript when system running nodejs is posix. does nothing on other platforms.+           , childUser :: Maybe UserID+            -- ^ Use posix setuid to set child process's user id; works for JavaScript when system running nodejs is posix. does nothing on other platforms.+           , useProcessJobs :: Bool+            -- ^ On Windows systems this flag indicates that we should wait for the entire process tree+            --   to finish before unblocking. On POSIX systems this flag is ignored. See $exec-on-windows for details.+           }+        -> CreateProcess ('SubprocMode i o e lp ls)++data StdStream s where+    CreatePipe :: StdStream 'Piped+        -- ^ Create a new pipe.  The returned+        -- @Handle@ will use the default encoding+        -- and newline translation mode (just+        -- like @Handle@s created by @openFile@).+    Inherit :: StdStream 'NoPipe+        -- ^ Inherit Handle from parent+    UseHandle+        :: Handle+        -> StdStream 'NoPipe+        -- ^ Use the supplied Handle+    NoStream :: StdStream 'NoPipe+        -- ^ Close the stream's file descriptor without+        -- passing a Handle. On POSIX systems this may+        -- lead to strange behavior in the child process+        -- because attempting to read or write after the+        -- file has been closed throws an error. This+        -- should only be used with child processes that+        -- don't use the file descriptor at all. If you+        -- wish to ignore the child process's output you+        -- should either create a pipe and drain it+        -- manually or pass a @Handle@ that writes to+        -- @\/dev\/null@.++data LifecycleMode t where+    KillMode :: LifecycleMode 'Kill+    WaitMode :: LifecycleMode 'Wait++process :: FilePath -> [String] -> CreateProcess ('SubprocMode 'NoPipe 'NoPipe 'NoPipe 'Wait 'Wait)+process cmd args = command $ RawCommand cmd args++shell :: String -> CreateProcess ('SubprocMode 'NoPipe 'NoPipe 'NoPipe 'Wait 'Wait)+shell = command . ShellCommand++command :: CmdSpec -> CreateProcess ('SubprocMode 'NoPipe 'NoPipe 'NoPipe 'Wait 'Wait)+command cmdspec = commandWith cmdspec Inherit Inherit Inherit WaitMode WaitMode++commandWith+    :: CmdSpec+    -> StdStream i+    -> StdStream o+    -> StdStream e+    -> LifecycleMode lp+    -> LifecycleMode ls+    -> CreateProcess ('SubprocMode i o e lp ls)+commandWith cmdspec stdin stdout stderr subprocLifecycle scopeLifecycle =+    CreateProcess+        { cmdspec = cmdspec+        , stdin = stdin+        , stdout = stdout+        , stderr = stderr+        , subprocLifecycle+        , scopeLifecycle+        , cwd = Nothing+        , env = Nothing+        , closeFds = False+        , createGroup = False+        , delegateCtlc = False+        , detachConsole = False+        , createNewConsole = False+        , newSession = False+        , childGroup = Nothing+        , childUser = Nothing+        , useProcessJobs = False+        }++toRawCreateProcess :: CreateProcess stdio -> Raw.CreateProcess+toRawCreateProcess (CreateProcess {..}) =+    Raw.CreateProcess+        { cmdspec = cmdspec+        , cwd = cwd+        , env = env+        , std_in = toRawStdStream stdin+        , std_out = toRawStdStream stdout+        , std_err = toRawStdStream stderr+        , close_fds = closeFds+        , create_group = createGroup+        , delegate_ctlc = delegateCtlc+        , detach_console = detachConsole+        , create_new_console = createNewConsole+        , new_session = newSession+        , child_group = childGroup+        , child_user = childUser+        , use_process_jobs = useProcessJobs+        }++toRawStdStream :: StdStream pipe -> Raw.StdStream+toRawStdStream = \case+    CreatePipe -> Raw.CreatePipe+    Inherit -> Raw.Inherit+    UseHandle h -> Raw.UseHandle h+    NoStream -> Raw.NoStream

@@ -2,8 +2,19 @@  -- SPDX-License-Identifier: MPL-2.0 -module Control.Monad.Hefty.Concurrent.Timer where+{- |+Copyright   :  (c) 2024 Sayo Koyoneda+License     :  MPL-2.0 (see the LICENSE file)+Maintainer  :  ymdfield@outlook.jp +Interpreters for the [Timer]("Data.Effect.Concurrent.Timer") effects.+-}+module Control.Monad.Hefty.Concurrent.Timer (+    module Control.Monad.Hefty.Concurrent.Timer,+    module Data.Effect.Concurrent.Timer,+)+where+ import Control.Concurrent.Thread.Delay qualified as Thread import Control.Monad.Hefty (     interpose,@@ -19,7 +30,7 @@  ) import Control.Monad.Hefty.Coroutine (runCoroutine) import Control.Monad.Hefty.State (evalState)-import Data.Effect.Concurrent.Timer (CyclicTimer (Wait), Timer (..), clock, cyclicTimer)+import Data.Effect.Concurrent.Timer import Data.Effect.Coroutine (Status (Continue, Done)) import Data.Effect.State (get, put) import Data.Time (DiffTime)@@ -54,6 +65,7 @@                     Continue () k -> put =<< raise (k delta)         & evalState timer0 +-- | Re-zeros the clock time in the local scope. restartClock :: (Timer <| ef) => eh :!! ef ~> eh :!! ef restartClock a = do     t0 <- clock

@@ -1,13 +1,36 @@ -- SPDX-License-Identifier: MPL-2.0 -module Control.Monad.Hefty.Coroutine where+{- |+Copyright   :  (c) 2024 Sayo Koyoneda+License     :  MPL-2.0 (see the LICENSE file)+Maintainer  :  ymdfield@outlook.jp -import Control.Monad.Hefty.Interpret (interpretBy)-import Control.Monad.Hefty.Types (Eff)-import Data.Effect.Coroutine (Status (Continue, Done), Yield (Yield))+Interpreters for the [coroutine]("Data.Effect.Coroutine") effect.+-}+module Control.Monad.Hefty.Coroutine (+    module Control.Monad.Hefty.Coroutine,+    module Data.Effect.Coroutine,+    module Data.Effect.Input,+    module Data.Effect.Output,+)+where +import Control.Monad.Hefty (Eff, interpretBy, type (~>))+import Data.Effect.Coroutine+import Data.Effect.Input+import Data.Effect.Output++-- | Interpret the [coroutine]("Data.Effect.Coroutine")'s t'Yield' effect. runCoroutine-    :: forall a b ans r-     . Eff '[] (Yield a b ': r) ans-    -> Eff '[] r (Status (Eff '[] r) a b ans)+    :: forall a b ans ef+     . Eff '[] (Yield a b ': ef) ans+    -> Eff '[] ef (Status (Eff '[] ef) a b ans) runCoroutine = interpretBy (pure . Done) (\(Yield a) k -> pure $ Continue a k)++-- | Converts the t'Input' effect into the [coroutine]("Data.Effect.Coroutine")'s t'Yield' effect.+inputToYield :: Input i ~> Yield () i+inputToYield Input = Yield ()++-- | Converts the t'Output' effect into the [coroutine]("Data.Effect.Coroutine")'s t'Yield' effect.+outputToYield :: Output o ~> Yield o ()+outputToYield (Output o) = Yield o

@@ -1,70 +1,69 @@--- 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 License     :  MPL-2.0 (see the LICENSE file) Maintainer  :  ymdfield@outlook.jp-Portability :  portable -Interpreters for the t'Data.Effect.Except.Throw' / t'Data.Effect.Except.Catch' effects.+Interpreters for the [Except]("Data.Effect.Except") effects. -}-module Control.Monad.Hefty.Except where+module Control.Monad.Hefty.Except (+    module Control.Monad.Hefty.Except,+    module Data.Effect.Except,+)+where  import Control.Exception (Exception) import Control.Monad.Hefty (     Eff,     Interpreter,-    bundleAllH,     interposeWith,     interpret,     interpretBy,     interpretH,-    nilH,-    (!!+),     (&),     type (<<|),     type (<|),     type (~>),     type (~~>),  )-import Data.Effect.Except (Catch (Catch), Throw (Throw))+import Data.Effect.Except import Data.Effect.Unlift (UnliftIO) import UnliftIO (throwIO) import UnliftIO qualified as IO +-- | Interpret the t'Throw'/t'Catch' effects. runExcept :: Eff '[Catch e] (Throw e ': r) a -> Eff '[] r (Either e a) runExcept = runThrow . runCatch +-- | Interpret the t'Throw' effect. runThrow :: Eff '[] (Throw e ': r) a -> Eff '[] r (Either e a) runThrow = interpretBy (pure . Right) handleThrow +-- | Interpret the t'Catch' effect. runCatch :: (Throw e <| ef) => Eff '[Catch e] ef ~> Eff '[] ef runCatch = interpretH elabCatch +-- | A handler function for the t'Throw' effect. handleThrow :: Interpreter (Throw e) (Eff '[] r) (Either e a) handleThrow (Throw e) _ = pure $ Left e {-# INLINE handleThrow #-} +-- | A elaborator function for the t'Catch' effect. elabCatch :: (Throw e <| ef) => Catch e ~~> Eff '[] ef elabCatch (Catch action hdl) = action & interposeWith \(Throw e) _ -> hdl e {-# INLINE elabCatch #-} +-- | Interpret the t'Throw' effect based on an IO-fused semantics using IO-level exceptions. runThrowIO     :: forall e eh ef      . (IO <| ef, Exception e)     => Eff eh (Throw e ': ef) ~> Eff eh ef runThrowIO = interpret \(Throw e) -> throwIO e +-- | Interpret the t'Catch' effect based on an IO-fused semantics using IO-level exceptions. runCatchIO     :: forall e eh ef      . (UnliftIO <<| eh, IO <| ef, Exception e)     => Eff (Catch e ': eh) ef ~> Eff eh ef runCatchIO = interpretH \(Catch action hdl) -> IO.catch action hdl--prog :: Eff '[Catch String, Catch Int] '[Throw String, Throw Int] ()-prog = undefined--prog' :: Eff '[] [Throw String, Throw Int] ()-prog' = interpretH (elabCatch @String !!+ elabCatch @Int !!+ nilH) . bundleAllH $ prog

@@ -8,10 +8,15 @@ Maintainer  :  ymdfield@outlook.jp Portability :  portable -}-module Control.Monad.Hefty.Fail where+module Control.Monad.Hefty.Fail (+    module Control.Monad.Hefty.Fail,+    module Data.Effect.Fail,+)+where +import Control.Monad.Fail qualified as IO import Control.Monad.Hefty (Eff, interpret, liftIO, type (<|), type (~>))-import Data.Effect.Fail (Fail (Fail))+import Data.Effect.Fail  runFailIO :: (IO <| ef) => Eff eh (Fail ': ef) ~> Eff eh ef-runFailIO = interpret \(Fail s) -> liftIO $ fail s+runFailIO = interpret \(Fail s) -> liftIO $ IO.fail s

@@ -8,12 +8,15 @@ Maintainer  :  ymdfield@outlook.jp Portability :  portable -}-module Control.Monad.Hefty.Fresh where+module Control.Monad.Hefty.Fresh (+    module Control.Monad.Hefty.Fresh,+    module Data.Effect.Fresh,+) where  import Control.Arrow ((>>>)) import Control.Monad.Hefty (Eff, interpret, raiseUnder, type (<|), type (~>)) import Control.Monad.Hefty.State (runState)-import Data.Effect.Fresh (Fresh (Fresh))+import Data.Effect.Fresh import Data.Effect.State (State, get, modify) import Numeric.Natural (Natural) 

@@ -1,34 +1,44 @@--- 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 License     :  MPL-2.0 (see the LICENSE file) Maintainer  :  ymdfield@outlook.jp-Portability :  portable++Interpreters for the t'Input' effect. -}-module Control.Monad.Hefty.Input where+module Control.Monad.Hefty.Input (+    module Control.Monad.Hefty.Input,+    module Data.Effect.Input,+)+where  import Control.Arrow ((>>>)) import Control.Monad.Hefty (Eff, interpret, raiseUnder, type (~>)) import Control.Monad.Hefty.State (evalState)-import Data.Effect.Input (Input (Input))+import Data.Effect.Input import Data.Effect.State (gets, put) import Data.List (uncons) +-- | Interprets the t'Input' effect by executing the given input handler each time an input is required. runInputEff     :: forall i ef eh      . Eff eh ef i     -> Eff eh (Input i ': ef) ~> Eff eh ef runInputEff a = interpret \Input -> a +-- | Interprets the t'Input' effect by providing the given constant as input. runInputConst     :: forall i ef eh      . i     -> Eff eh (Input i ': ef) ~> Eff eh ef runInputConst i = interpret \Input -> pure i +{- |+Interprets the t'Input' effect by using the given list as a series of inputs.++Each time 'input' is called, it retrieves elements from the list one by one from the beginning, and after all elements are consumed, 'Nothing' is returned indefinitely.+-} runInputList :: forall i r. [i] -> Eff '[] (Input (Maybe i) ': r) ~> Eff '[] r runInputList is =     raiseUnder

@@ -12,12 +12,16 @@ from [@Polysemy.KVStore@](https://hackage.haskell.org/package/polysemy-kvstore-0.1.3.0/docs/Polysemy-KVStore.html) in the @polysemy-kvstore@ package. -}-module Control.Monad.Hefty.KVStore where+module Control.Monad.Hefty.KVStore (+    module Control.Monad.Hefty.KVStore,+    module Data.Effect.KVStore,+)+where  import Control.Arrow ((>>>)) import Control.Monad.Hefty (Eff, interpret, raiseUnder, type (<|), type (~>)) import Control.Monad.Hefty.State (runState)-import Data.Effect.KVStore (KVStore (LookupKV, UpdateKV))+import Data.Effect.KVStore import Data.Effect.State (State, get, modify) import Data.Functor ((<&>)) import Data.Map (Map)

@@ -0,0 +1,34 @@+-- SPDX-License-Identifier: MPL-2.0++{- |+Copyright   :  (c) 2024 Sayo Koyoneda+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 Control.Monad.Hefty.Log (+    module Control.Monad.Hefty.Log,+    module Data.Effect.Log,+)+where++import Colog.Core (LogAction (LogAction))+import Control.Monad.Hefty (Eff, interpret, send, type (<|), type (~>))+import Control.Monad.Hefty.Output (Output (..), output)+import Data.Effect.Log+import Prelude hiding (log)++runLogAsOutput :: (Output msg <| ef) => Eff eh (Log msg ': ef) ~> Eff eh ef+runLogAsOutput = interpret \(Log msg) -> output msg++runOutputAsLog :: (Log msg <| ef) => Eff eh (Output msg ': ef) ~> Eff eh ef+runOutputAsLog = interpret \(Output msg) -> log msg++runLogAction :: LogAction (Eff eh ef) msg -> Eff eh (Log msg ': ef) ~> Eff eh ef+runLogAction (LogAction f) = interpret \(Log msg) -> f msg++runLogActionEmbed :: (m <| ef) => LogAction m msg -> Eff eh (Log msg ': ef) ~> Eff eh ef+runLogActionEmbed (LogAction f) = interpret \(Log msg) -> send $ f msg

@@ -1,36 +1,47 @@ {-# LANGUAGE CPP #-}+{-# LANGUAGE DeriveAnyClass #-}+{-# OPTIONS_GHC -fplugin GHC.TypeLits.KnownNat.Solver #-} --- 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 License     :  MPL-2.0 (see the LICENSE file) Maintainer  :  ymdfield@outlook.jp-Portability :  portable++Interpreters for the [non-determinism]("Data.Effect.NonDet") effects. -}-module Control.Monad.Hefty.NonDet where+module Control.Monad.Hefty.NonDet (+    module Control.Monad.Hefty.NonDet,+    module Data.Effect.NonDet,+)+where -import Control.Applicative (Alternative ((<|>)), empty, (<|>))+import Control.Applicative (Alternative ((<|>)), (<|>)) #if ( __GLASGOW_HASKELL__ < 906 ) import Control.Applicative (liftA2) #endif+import Control.Applicative qualified as A import Control.Arrow ((>>>)) import Control.Monad.Hefty (     Eff,     bundleN,+    interpret,     interpretBy,     interpretH,     nil,     (!+),+    (&),+    type (<<|),     type (<|),     type (~>),  ) import Data.Bool (bool)-import Data.Effect.NonDet (Choose (Choose), ChooseH (ChooseH), Empty (Empty), choose)+import Data.Effect.NonDet+import Data.Effect.Unlift (UnliftIO)+import UnliftIO (Exception, SomeException, throwIO, try) --- | 'NonDet' effects handler for alternative answer type.+-- | [NonDet]("Data.Effect.NonDet") effects handler for alternative answer type. runNonDet     :: forall f ef a      . (Alternative f)@@ -41,11 +52,11 @@         >>> interpretBy             (pure . pure)             ( (\Choose k -> liftA2 (<|>) (k False) (k True))-                !+ (\Empty _ -> pure empty)+                !+ (\Empty _ -> pure A.empty)                 !+ nil             ) --- | 'NonDet' effects handler for monoidal answer type.+-- | [NonDet]("Data.Effect.NonDet") effects handler for monoidal answer type. runNonDetMonoid     :: forall ans ef a      . (Monoid ans)@@ -61,7 +72,7 @@                 !+ nil             ) --- | 'Choose' effect handler for alternative answer type.+-- | t'Choose' effect handler for alternative answer type. runChoose     :: forall f ef a      . (Alternative f)@@ -71,7 +82,7 @@     interpretBy (pure . pure) \Choose k ->         liftA2 (<|>) (k False) (k True) --- | 'Choose' effect handler for monoidal answer type.+-- | t'Choose' effect handler for monoidal answer type. runChooseMonoid     :: forall ans ef a      . (Semigroup ans)@@ -82,14 +93,14 @@     interpretBy f \Choose k ->         liftA2 (<>) (k False) (k True) --- | 'Empty' effect handler.-runEmpty :: forall a r. Eff '[] (Empty ': r) a -> Eff '[] r (Maybe a)+-- | t'Empty' effect handler.+runEmpty :: forall a ef. Eff '[] (Empty ': ef) a -> Eff '[] ef (Maybe a) runEmpty =     interpretBy         (pure . Just)         \Empty _ -> pure Nothing -{- | 'ChooseH' effect elaborator.+{- | t'ChooseH' effect elaborator.      Convert a higher-order effect of the form @@ -110,3 +121,43 @@     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 :: (Choose <| ef, Empty <| ef) => [a] -> Eff eh ef a+choice = \case+    [] -> empty+    x : xs -> pure x `branch` choice xs++-- | Selects one element from the list nondeterministically, branching the control as many times as the number of elements. Uses t'ChooseH'.+choiceH :: (ChooseH <<| eh, Empty <| ef) => [a] -> Eff eh ef a+choiceH = \case+    [] -> empty+    x : xs -> pure x <|> choiceH xs++{- |+Interprets the [NonDet]("Data.Effect.NonDet") effects using IO-level exceptions.++When 'empty' occurs, an '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.+-}+runNonDetIO+    :: (UnliftIO <<| eh, IO <| ef)+    => Eff (ChooseH ': eh) (Empty ': ef) a+    -> Eff eh ef (Either SomeException a)+runNonDetIO m = try do+    m+        & interpretH+            ( \(ChooseH a b) ->+                try a >>= \case+                    Right x -> pure x+                    Left (_ :: SomeException) -> b+            )+        & interpret (\Empty -> throwIO EmptyException)++-- | Exception thrown when 'empty' occurs in 'runNonDetIO'.+data EmptyException = EmptyException+    deriving stock (Show)+    deriving anyclass (Exception)

@@ -1,34 +1,40 @@--- 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 License     :  MPL-2.0 (see the LICENSE file) Maintainer  :  ymdfield@outlook.jp-Portability :  portable++Interpreters for the t'Output' effect. -}-module Control.Monad.Hefty.Output where+module Control.Monad.Hefty.Output (+    module Control.Monad.Hefty.Output,+    module Data.Effect.Output,+)+where  import Control.Arrow ((>>>)) import Control.Monad.Hefty (Eff, interpret, interpretStateBy, raiseUnder, type (~>)) import Control.Monad.Hefty.State (runState) import Control.Monad.Hefty.Writer (handleTell)-import Data.Effect.Output (Output (Output))+import Data.Effect.Output import Data.Effect.State (modify) import Data.Effect.Writer (Tell (Tell)) +-- | Interprets the t'Output' effect using the given output handler. runOutputEff     :: forall o ef eh      . (o -> Eff eh ef ())     -> Eff eh (Output o ': ef) ~> Eff eh ef runOutputEff f = interpret \(Output o) -> f o +-- | Interprets the t'Output' effect by ignoring the outputs. ignoreOutput     :: forall o ef eh      . Eff eh (Output o ': ef) ~> Eff eh ef ignoreOutput = runOutputEff $ const $ pure () +-- | Interprets the t'Output' effect by accumulating the outputs into a list. runOutputList     :: forall o a ef      . Eff '[] (Output o ': ef) a@@ -38,7 +44,7 @@         >>> interpret (\(Output o) -> modify (o :))         >>> runState [] --- | Run an `Output` effect by transforming into a monoid.+-- | Interprets the t'Output' effect by accumulating the outputs into a monoid. runOutputMonoid     :: forall o w a ef      . ( Monoid w

@@ -1,97 +1,128 @@-{-# LANGUAGE UndecidableInstances #-}- -- SPDX-License-Identifier: MPL-2.0  {- | Copyright   :  (c) 2024 Sayo Koyoneda License     :  MPL-2.0 (see the LICENSE file) Maintainer  :  ymdfield@outlook.jp++Interpreters for the [Provider]("Data.Effect.Provider") effects. -}-module Control.Monad.Hefty.Provider where+module Control.Monad.Hefty.Provider (+    module Control.Monad.Hefty.Provider,+    module Data.Effect.Provider,+)+where  import Control.Monad.Hefty (     Eff,     HFunctor,+    KeyH (KeyH),     MemberHBy,+    Type,     interpretH,-    raise,-    raiseNH,-    tag,-    tagH,-    untag,-    untagH,+    key,+    keyH,+    transEffHF,+    unkey,+    unkeyH,+    weaken,+    weakenNH,+    type (##>),+    type (#>),     type (~>),  )-import Data.Effect.Key (KeyH (KeyH))-import Data.Effect.Provider (Provider, Provider' (Provide), ProviderKey)-import Data.Effect.Provider qualified as P-import Data.Effect.Tag (type (#), type (##))+import Data.Effect.Provider+import Data.Functor.Const (Const (Const)) import Data.Functor.Identity (Identity (Identity)) -type ProviderFix ctx i eh rh ef rf = Provider ctx i (ProviderBase ctx i eh rh ef rf)-type ProviderFix_ i eh rh ef rf = Provider Identity i (ProviderBase Identity i eh rh ef rf)+type Provide ctx i sh sf eh ef = Provider ctx i (ProviderEff ctx i sh sf eh ef) -newtype ProviderBase ctx i eh rh ef rf a-    = ProviderBase-    { unProviderBase-        :: Eff (eh ': ProviderFix ctx i eh rh ef rf ': rh) (ef ': rf) a-    }-    deriving newtype (Functor, Applicative, Monad)+newtype ProviderEff ctx i sh sf eh ef p a+    = ProviderEff {unProviderEff :: Eff (sh p ': Provide ctx i sh sf eh ef ': eh) (sf p ': ef) a} +type Provide_ i sh sf eh ef =+    Provider (Const1 Identity) (Const i :: () -> Type) (Const1 (ProviderEff_ i sh sf eh ef))++newtype ProviderEff_ i sh sf eh ef a+    = ProviderEff_ {unProviderEff_ :: Eff (sh ': Provide_ i sh sf eh ef ': eh) (sf ': ef) a}++-- | Interpret the t'Provider' effect using the given effect interpreter. runProvider-    :: forall ctx i eh rh ef rf-     . ( forall x-          . i-         -> Eff (eh ': ProviderFix ctx i eh rh ef rf ': rh) (ef ': rf) x-         -> Eff (ProviderFix ctx i eh rh ef rf ': rh) rf (ctx x)+    :: forall ctx i sh sf eh ef+     . ( forall p x+          . i p+         -> Eff (sh p ': Provide ctx i sh sf eh ef ': eh) (sf p ': ef) x+         -> Eff (Provide ctx i sh sf eh ef ': eh) ef (ctx p x)        )-    -> Eff (ProviderFix ctx i eh rh ef rf ': rh) rf ~> Eff rh rf-runProvider run = loop-  where-    loop :: Eff (ProviderFix ctx i eh rh ef rf ': rh) rf ~> Eff rh rf-    loop = interpretH \(KeyH (Provide i f)) ->-        loop . run i . unProviderBase $-            f (ProviderBase . raiseNH @2 . raise)+    -> Eff (Provide ctx i sh sf eh ef ': eh) ef ~> Eff eh ef+runProvider run =+    interpretH \(KeyH (Provide i f)) ->+        runProvider run $+            run i (unProviderEff $ f $ ProviderEff . transEffHF (weakenNH @2) weaken) +{- |+Interpret the t'Provider' effect using the given effect interpreter.+A version of 'runProvider' where the type of t'Provider' is simpler.+-} runProvider_-    :: forall i eh rh ef rf-     . ( i-         -> Eff (eh ': ProviderFix_ i eh rh ef rf ': rh) (ef ': rf)-            ~> Eff (ProviderFix_ i eh rh ef rf ': rh) rf+    :: forall i sh sf eh ef+     . (HFunctor sh)+    => ( forall x+          . i+         -> Eff (sh ': Provide_ i sh sf eh ef ': eh) (sf ': ef) x+         -> Eff (Provide_ i sh sf eh ef ': eh) ef x        )-    -> Eff (ProviderFix_ i eh rh ef rf ': rh) rf ~> Eff rh rf-runProvider_ run = runProvider \i m -> run i $ Identity <$> m+    -> Eff (Provide_ i sh sf eh ef ': eh) ef ~> Eff eh ef+runProvider_ run =+    interpretH \(KeyH (Provide (Const i) f)) ->+        runProvider_ run $+            run+                i+                ( fmap (Const1 . Identity)+                    . unProviderEff_+                    . getConst1+                    $ f+                    $ Const1+                        . ProviderEff_+                        . transEffHF (weakenNH @2) weaken+                ) -provide-    :: forall tag ctx i eh ef a sh bh sf bf+-- | Introduces a new local scope that provides effects @sh p@ and @sf p@ parameterized by @i p@ value and with results wrapped in @ctx p@.+scope+    :: forall key ctx i p eh ef a sh sf bh bf      . ( MemberHBy             (ProviderKey ctx i)-            (Provider' ctx i (ProviderBase ctx i sh bh sf bf))+            (Provider' ctx i (ProviderEff ctx i sh sf bh bf))             eh-       , HFunctor sh+       , HFunctor (sh p)        )-    => i-    -> ( (Eff eh ef ~> Eff (sh ## tag ': ProviderFix ctx i sh bh sf bf ': bh) (sf # tag ': bf))-         -> Eff (sh ## tag ': ProviderFix ctx i sh bh sf bf ': bh) (sf # tag ': bf) a+    => i p+    -> ( Eff eh ef ~> Eff (key ##> sh p ': Provide ctx i sh sf bh bf ': bh) (key #> sf p ': bf)+         -> Eff (key ##> sh p ': Provide ctx i sh sf bh bf ': bh) (key #> sf p ': bf) a        )-    -> Eff eh ef (ctx a)-provide i f =-    i P...! \runInBase ->-        ProviderBase . untag . untagH $ f $ tagH . tag . unProviderBase . runInBase+    -> Eff eh ef (ctx p a)+scope i f =+    i ..! \runInScope ->+        ProviderEff $ unkeyH . unkey $ f (keyH . key . unProviderEff . runInScope) -provide_-    :: forall tag i eh ef a sh bh sf bf+-- | Introduces a new local scope that provides effects @sh@ and @sf@ parameterized by @i@ value.+scope_+    :: forall key i eh ef a sh sf bh bf      . ( MemberHBy-            (ProviderKey Identity i)-            (Provider' Identity i (ProviderBase Identity i sh bh sf bf))+            (ProviderKey (Const1 Identity :: () -> Type -> Type) (Const i :: () -> Type))+            ( Provider'+                (Const1 Identity)+                (Const i)+                (Const1 (ProviderEff_ i sh sf bh bf))+            )             eh        , HFunctor sh        )     => i-    -> ( (Eff eh ef ~> Eff (sh ## tag ': ProviderFix_ i sh bh sf bf ': bh) (sf # tag ': bf))-         -> Eff (sh ## tag ': ProviderFix_ i sh bh sf bf ': bh) (sf # tag ': bf) a+    -> ( Eff eh ef ~> Eff (key ##> sh ': Provide_ i sh sf bh bf ': bh) (key #> sf ': bf)+         -> Eff (key ##> sh ': Provide_ i sh sf bh bf ': bh) (key #> sf ': bf) a        )     -> Eff eh ef a-provide_ i f =-    i P..! \runInBase ->-        ProviderBase . untag . untagH $ f $ tagH . tag . unProviderBase . runInBase+scope_ i f =+    i .! \runInScope ->+        ProviderEff_ $ unkeyH . unkey $ f (keyH . key . unProviderEff_ . runInScope)

@@ -1,16 +1,17 @@--- 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 License     :  MPL-2.0 (see the LICENSE file) Maintainer  :  ymdfield@outlook.jp-Portability :  portable -Interpreters for the t'Ask' / t'Local' effects.+Interpreters for the [Reader]("Data.Effect.Reader") effects. -}-module Control.Monad.Hefty.Reader where+module Control.Monad.Hefty.Reader (+    module Control.Monad.Hefty.Reader,+    module Data.Effect.Reader,+)+where  import Control.Monad.Hefty (     Eff,@@ -22,21 +23,23 @@     type (~>),     type (~~>),  )-import Data.Effect.Reader (Ask (..), Local (..), ask)+import Data.Effect.Reader +-- | Interpret the t'Ask'/t'Local' effects. runReader     :: forall r eh ef      . r     -> Eff (Local r ': eh) (Ask r ': ef) ~> Eff eh ef runReader r = runAsk r . runLocal --- | Elaborate the t'Local' effect.+-- | Interpret the t'Local' effect. runLocal     :: forall r eh ef      . (Ask r <| ef)     => Eff (Local r ': eh) ef ~> Eff eh ef runLocal = interpretH elabLocal +-- | A elaborator function for the t'Local' effect. elabLocal     :: forall r eh ef      . (Ask r <| ef)

@@ -12,16 +12,21 @@  An elaborator for the t'Control.Effect.Class.Resource.Resource' effect class. -}-module Control.Monad.Hefty.Resource where+module Control.Monad.Hefty.Resource (+    module Control.Monad.Hefty.Resource,+    module Data.Effect.Resource,+)+where  import Control.Effect (type (~>)) import Control.Monad.Hefty.Interpret (interpretH) import Control.Monad.Hefty.Types (Eff, type (~~>)) import Data.Effect.OpenUnion.Internal.FO (type (<|)) import Data.Effect.OpenUnion.Internal.HO (type (<<|))-import Data.Effect.Resource (Resource (Bracket, BracketOnExcept))+import Data.Effect.Resource import Data.Effect.Unlift (UnliftIO)-import UnliftIO (MonadUnliftIO, bracket, bracketOnError)+import UnliftIO (MonadUnliftIO)+import UnliftIO qualified as IO  -- | Elaborates the `Resource` effect under the `UnliftIO` context. runResourceIO@@ -31,6 +36,6 @@  elabResourceIO :: (MonadUnliftIO m) => Resource ~~> m elabResourceIO = \case-    Bracket acquire release thing -> bracket acquire release thing-    BracketOnExcept acquire onError thing -> bracketOnError acquire onError thing+    Bracket acquire release thing -> IO.bracket acquire release thing+    BracketOnExcept acquire onError thing -> IO.bracketOnError acquire onError thing {-# INLINE elabResourceIO #-}

@@ -2,46 +2,65 @@ -- 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 Control.Monad.Hefty.ShiftReset where+module Control.Monad.Hefty.ShiftReset (+    module Control.Monad.Hefty.ShiftReset,+    module Data.Effect.ShiftReset,+)+where  import Control.Monad.Hefty (     Eff,+    MemberHBy,+    interpret,+    interpretBy,     interpretH,     interpretHBy,     interpretRecHWith,     raiseH,     runEff,+    send0,+    sendH,     type (~>),  ) import Data.Effect.Key (KeyH (KeyH))-import Data.Effect.ShiftReset (-    Reset (Reset),-    Shift,-    Shift' (Shift),-    Shift_,-    Shift_' (Shift_'),- )+import Data.Effect.ShiftReset (Shift' (Shift))+import Data.Effect.ShiftReset hiding (Shift)+import Data.Effect.ShiftReset qualified as D -type ShiftFix ans eh ef = Shift ans (ShiftBase ans eh ef)+type Shift ans eh ef = D.Shift ans (ShiftEff ans eh ef) -newtype ShiftBase ans eh ef a-    = ShiftBase {unShiftBase :: Eff (Shift ans (ShiftBase ans eh ef) ': eh) ef a}+newtype ShiftEff ans eh ef a+    = ShiftEff {unShiftEff :: Eff (D.Shift ans (ShiftEff ans eh ef) ': eh) ef a}     deriving newtype (Functor, Applicative, Monad) -evalShift :: Eff '[ShiftFix ans '[] ef] ef ans -> Eff '[] ef ans+evalShift :: Eff '[Shift ans '[] ef] ef ans -> Eff '[] ef ans evalShift = runShift pure -runShift :: (a -> Eff '[] ef ans) -> Eff '[ShiftFix ans '[] ef] ef a -> Eff '[] ef ans+runShift :: (a -> Eff '[] ef ans) -> Eff '[Shift ans '[] ef] ef a -> Eff '[] ef ans runShift f =     interpretHBy f \e k ->         evalShift $ case e of-            KeyH (Shift g) -> unShiftBase $ g (ShiftBase . raiseH . k) ShiftBase+            KeyH (Shift initiate) -> unShiftEff $ initiate (ShiftEff . raiseH . k) ShiftEff -withShift :: Eff '[ShiftFix ans '[] '[Eff eh ef]] '[Eff eh ef] ans -> Eff eh ef ans+withShift :: Eff '[Shift ans '[] '[Eff eh ef]] '[Eff eh ef] ans -> Eff eh ef ans withShift = runEff . evalShift -runShift_ :: forall r ef. Eff (Shift_ (Eff r ef) ': r) ef ~> Eff r ef-runShift_ = interpretRecHWith \(KeyH (Shift_' f)) k -> f k id+runShift_ :: forall eh ef. Eff (Shift_ (Eff eh ef) ': eh) ef ~> Eff eh ef+runShift_ = interpretRecHWith \(KeyH (Shift_' initiate)) k -> initiate k id -runReset :: forall r ef. Eff (Reset ': r) ef ~> Eff r ef+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

@@ -6,11 +6,14 @@ Copyright   :  (c) 2023 Sayo Koyoneda License     :  MPL-2.0 (see the LICENSE file) Maintainer  :  ymdfield@outlook.jp-Portability :  portable  Interpreter for the t'Data.Effect.State.State' effect. -}-module Control.Monad.Hefty.State where+module Control.Monad.Hefty.State (+    module Control.Monad.Hefty.State,+    module Data.Effect.State,+)+where  import Control.Arrow ((>>>)) import Control.Monad.Hefty (@@ -30,29 +33,39 @@  ) import Control.Monad.Hefty.Reader (runAsk) import Data.Effect.Reader (Ask (Ask), ask)-import Data.Effect.State (State (Get, Put), get, put)+import Data.Effect.State import Data.Functor ((<&>)) import UnliftIO (newIORef, readIORef, writeIORef) --- | Interpret the 'Get'/'Put' effects.+-- | Interpret the 'State' effect. runState :: forall s ef a. s -> Eff '[] (State s ': ef) a -> Eff '[] ef (s, a) runState s0 = interpretStateBy s0 (curry pure) handleState +-- | Interpret the 'State' effect. Do not include the final state in the return value. evalState :: forall s ef a. s -> Eff '[] (State s ': ef) a -> Eff '[] ef a evalState s0 = interpretStateBy s0 (const pure) handleState +-- | Interpret the 'State' effect. Do not include the final result in the return value. execState :: forall s ef a. s -> Eff '[] (State s ': ef) a -> Eff '[] ef s execState s0 = interpretStateBy s0 (\s _ -> pure s) handleState -runStateRec :: forall s ef eh. s -> Eff eh (State s ': ef) ~> Eff eh ef-runStateRec s0 = interpretStateRecWith s0 handleState+{- |+Interpret the 'State' effect. +Interpretation is performed recursively with respect to the scopes of unelaborated higher-order effects @eh@.+Note that the state is reset and does not persist beyond the scopes.+-}+evalStateRec :: forall s ef eh. s -> Eff eh (State s ': ef) ~> Eff eh ef+evalStateRec s0 = interpretStateRecWith s0 handleState++-- | A handler function for the 'State' effect. handleState :: StateInterpreter s (State s) (Eff eh r) ans handleState = \case     Put s -> \_ k -> k s ()     Get -> \s k -> k s s {-# INLINE handleState #-} +-- | Interpret the 'State' effect based on an IO-fused semantics using t'Data.IORef.IORef'. runStateIORef     :: forall s ef eh a      . (IO <| ef)@@ -67,6 +80,23 @@             Put s -> writeIORef ref s     readIORef ref <&> (,a) +{- |+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 ef eh a+     . (IO <| ef)+    => s+    -> Eff eh (State s ': ef) a+    -> Eff eh ef a+evalStateIORef s0 m = do+    ref <- newIORef s0+    m & interpret \case+        Get -> readIORef ref+        Put s -> writeIORef ref s++-- | Within the given scope, make the state roll back to the beginning of the scope in case of exceptions, etc. transactState :: forall s ef. (State s <| ef) => Eff '[] ef ~> Eff '[] ef transactState m = do     pre <- get @s@@ -83,9 +113,9 @@             Put s -> \k -> pure \_ -> k () >>= ($ s)     f s0 --- | A naive but somewhat slower version of 'runStateRec' that does not use ad-hoc optimizations.-runStateNaiveRec :: forall s ef eh. s -> Eff eh (State s ': ef) ~> Eff eh ef-runStateNaiveRec s0 =+-- | A naive but somewhat slower version of 'evalStateRec' that does not use ad-hoc optimizations.+evalStateNaiveRec :: forall s ef eh. s -> Eff eh (State s ': ef) ~> Eff eh ef+evalStateNaiveRec s0 =     raiseUnder         >>> interpretRecWith \case             Get -> (ask @s >>=)

@@ -1,23 +1,29 @@--- 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 License     :  MPL-2.0 (see the LICENSE file) Maintainer  :  ymdfield@outlook.jp-Portability :  portable++Interpreters for the [Unlift]("Data.Effect.Unlift") effects. -}-module Control.Monad.Hefty.Unlift where+module Control.Monad.Hefty.Unlift (+    module Control.Monad.Hefty.Unlift,+    module Data.Effect.Unlift,+)+where  import Control.Monad.Hefty (Eff, interpretH, runEff, send0, type (~>))-import Data.Effect.Unlift (UnliftBase (WithRunInBase), UnliftIO)+import Data.Effect.Unlift+import UnliftIO (MonadUnliftIO)+import UnliftIO qualified as IO  runUnliftBase :: forall b. (Monad b) => Eff '[UnliftBase b] '[b] ~> b runUnliftBase =     runEff . interpretH \(WithRunInBase f) ->         send0 $ f runEff -runUnliftIO :: Eff '[UnliftIO] '[IO] ~> IO-runUnliftIO = runUnliftBase-{-# INLINE runUnliftIO #-}+runUnliftIO :: (MonadUnliftIO m) => Eff '[UnliftIO] '[m] ~> m+runUnliftIO =+    runEff . interpretH \(WithRunInBase f) ->+        send0 $ IO.withRunInIO \run -> f $ run . runEff

@@ -1,19 +1,17 @@-{-# 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 License     :  MPL-2.0 (see the LICENSE file) Maintainer  :  ymdfield@outlook.jp-Portability :  portable -Interpreter and elaborator for the t'Data.Effect.Writer.Writer' effect class.-See [README.md](https://github.com/sayo-hs/heftia/blob/master/README.md).+Interpreters for the [Writer]("Data.Effect.Writer") effects. -}-module Control.Monad.Hefty.Writer where+module Control.Monad.Hefty.Writer (+    module Control.Monad.Hefty.Writer,+    module Data.Effect.Writer,+)+where  import Control.Monad.Hefty (     Eff,@@ -26,42 +24,46 @@     type (<|),     type (~>),  )-import Data.Effect.Writer (Tell (Tell), WriterH (Censor, Listen), tell)+import Data.Effect.Writer --- | 'Writer' effect handler with post-applying censor semantics.+-- | Interpret the [Writer]("Data.Effect.Writer") effects with post-applying censor semantics. runWriterPost :: (Monoid w) => Eff '[WriterH w] (Tell w ': ef) a -> Eff '[] ef (w, a) runWriterPost = runTell . runWriterHPost --- | 'Writer' effect handler with pre-applying censor semantics.+-- | Interpret the [Writer]("Data.Effect.Writer") effects with pre-applying censor semantics. runWriterPre :: (Monoid w) => Eff '[WriterH w] (Tell w ': ef) a -> Eff '[] ef (w, a) runWriterPre = runTell . runWriterHPre +-- | Interpret the t'Tell' effect. runTell :: (Monoid w) => Eff '[] (Tell w ': ef) a -> Eff '[] ef (w, a) runTell = interpretStateBy mempty (curry pure) handleTell +-- | A handler function for the t'Tell' effect. handleTell :: (Monoid w) => StateInterpreter w (Tell w) (Eff '[] ef) (w, a) handleTell (Tell w') w k = k (w <> w') () {-# INLINE handleTell #-} +-- | Interpret the 'WriterH' effect with post-applying censor semantics. runWriterHPost :: (Monoid w, Tell w <| ef) => Eff '[WriterH w] ef ~> Eff '[] ef runWriterHPost = interpretH \case-    Listen m -> listen m+    Listen m -> intercept m     Censor f m -> censorPost f m +-- | Interpret the 'WriterH' effect with pre-applying censor semantics. runWriterHPre :: (Monoid w, Tell w <| ef) => Eff '[WriterH w] ef ~> Eff '[] ef runWriterHPre = interpretH \case-    Listen m -> listen m+    Listen m -> intercept m     Censor f m -> censorPre f m  {- | Retrieves the monoidal value accumulated by v'tell' within the given action. The v'tell' effect is not consumed and remains intact. -}-listen+intercept     :: forall w ef a      . (Tell w <| ef, Monoid w)     => Eff '[] ef a     -> Eff '[] ef (w, a)-listen =+intercept =     interposeStateBy @_ @(Tell w)         mempty         (curry pure)@@ -79,6 +81,7 @@     -> Eff '[] ef (w, a) confiscate = interposeStateBy mempty (curry pure) handleTell +-- | 'censor' with post-applying semantics. censorPost     :: forall w ef      . (Tell w <| ef, Monoid w)@@ -89,6 +92,7 @@     tell $ f w     pure a +-- | 'censor' with pre-applying semantics. censorPre     :: forall w eh ef      . (Tell w <| ef, Monoid w)

@@ -0,0 +1,98 @@+{-# LANGUAGE ApplicativeDo #-}+{-# OPTIONS_GHC -fplugin GHC.TypeLits.KnownNat.Solver #-}++-- SPDX-License-Identifier: MPL-2.0++module Test.Concurrent where++import Control.Applicative ((<|>))+import Control.Monad.Hefty (Eff, liftIO, runEff, type (<<|), type (<|))+import Control.Monad.Hefty.Concurrent.Parallel (+    Concurrently (Concurrently, runConcurrently),+    Parallel,+    cancels,+    input,+    polling,+    runConcurrentIO,+    runParallelAsSequential,+ )+import Control.Monad.Hefty.Concurrent.Timer (runTimerIO, sleep)+import Control.Monad.Hefty.State (get, modify, runStateIORef)+import Control.Monad.Hefty.Unlift (runUnliftIO)+import Data.Functor ((<&>))+import Test.Hspec (Spec, it, shouldBe)++spec_Concurrent :: Spec+spec_Concurrent = do+    let+        prog :: (Parallel <<| eh, IO <| ef) => Eff eh ef (String, String)+        prog = runTimerIO . runStateIORef "" . runConcurrently $ do+            r <- Concurrently do+                sleep 0.001+                modify (<> "B")+                get @String <&> (<> "C")+            Concurrently do+                modify (<> "A")+            pure r++    it "Parallel" do+        (s, a) <- runUnliftIO . runConcurrentIO $ prog+        s `shouldBe` "AB"+        a `shouldBe` "ABC"++    it "Sequential" do+        (s, a) <- runEff . runParallelAsSequential $ prog+        s `shouldBe` "BA"+        a `shouldBe` "BC"++    it "Race" do+        (s, a) <-+            runUnliftIO . runTimerIO . runStateIORef "" . runConcurrentIO . runConcurrently $+                let a = Concurrently do+                        modify (<> "A")+                        sleep 0.002+                        pure '1'++                    b = Concurrently do+                        sleep 0.001+                        modify (<> "B")+                        sleep 0.002+                        modify (<> "C")+                        pure '2'+                 in a <|> b++        s `shouldBe` "AB"+        a `shouldBe` '1'++    it "Cancel" do+        (s, ((), b)) <-+            runUnliftIO . runTimerIO . runStateIORef "" . runConcurrentIO $+                sleep 0.001 `cancels` do+                    modify (<> "A")+                    sleep 0.002+                    modify (<> "B")++        s `shouldBe` "A"+        b `shouldBe` Nothing++    it "Poll" do+        (s, ()) <- runUnliftIO . runTimerIO . runStateIORef "" . runConcurrentIO $ do+            polling+                do+                    sleep 0.001+                    modify (<> "B")+                    get @String <&> (<> "C")+                do+                    modify (<> "A")++                    x <- input+                    liftIO $ x `shouldBe` Nothing @String++                    sleep 0.002++                    x' <- input+                    liftIO $ x' `shouldBe` Just "ABC"++                    pure ()++        s `shouldBe` "AB"