heftia-effects 0.3.1.0 → 0.4.0.0

raw patch · 54 files changed

+2230/−1710 lines, 54 filesdep +effdep +effectfuldep +eveffdep −extensibledep −freedep −transformersdep ~basedep ~containersdep ~data-effectsnew-component:exe:FileSystemProviderPVP ok

version bump matches the API change (PVP)

Dependencies added: eff, effectful, eveff, freer-simple, fused-effects, logict, mpeff, polysemy, tasty-bench

Dependencies removed: extensible, free, transformers

Dependency ranges changed: base, containers, data-effects, heftia, hspec, mtl, tasty, tasty-hspec, time, unliftio

API changes (from Hackage documentation)

Files

• ChangeLog.md +6/−0
• Example/Continuation/Main.hs +20/−13
• Example/Continuation2/Main.hs +35/−26
• Example/FileSystemProvider/Main.hs +68/−0
• Example/KeyedEffects/Main.hs +19/−13
• Example/Logging/Main.hs +59/−51
• Example/SemanticsZoo/Main.hs +72/−33
• Example/Teletype/Main.hs +17/−11
• Example/Writer/Main.hs +4/−7
• README.md +120/−100
• bench/BenchCatch.hs +115/−0
• bench/BenchCoroutine.hs +96/−0
• bench/BenchCountdown.hs +186/−0
• bench/BenchPyth.hs +152/−0
• bench/Main.hs +114/−0
• heftia-effects.cabal +83/−60
• src/Control/Effect/Interpreter/Heftia/Concurrent/Timer.hs +0/−54
• src/Control/Effect/Interpreter/Heftia/Coroutine.hs +0/−17
• src/Control/Effect/Interpreter/Heftia/Except.hs +0/−135
• src/Control/Effect/Interpreter/Heftia/Fail.hs +0/−26
• src/Control/Effect/Interpreter/Heftia/Fresh.hs +0/−54
• src/Control/Effect/Interpreter/Heftia/Input.hs +0/−62
• src/Control/Effect/Interpreter/Heftia/KVStore.hs +0/−65
• src/Control/Effect/Interpreter/Heftia/NonDet.hs +0/−158
• src/Control/Effect/Interpreter/Heftia/Output.hs +0/−98
• src/Control/Effect/Interpreter/Heftia/Provider.hs +0/−39
• src/Control/Effect/Interpreter/Heftia/Provider/Implicit.hs +0/−44
• src/Control/Effect/Interpreter/Heftia/Reader.hs +0/−72
• src/Control/Effect/Interpreter/Heftia/Resource.hs +0/−26
• src/Control/Effect/Interpreter/Heftia/ShiftReset.hs +0/−70
• src/Control/Effect/Interpreter/Heftia/State.hs +0/−120
• src/Control/Effect/Interpreter/Heftia/Unlift.hs +0/−34
• src/Control/Effect/Interpreter/Heftia/Writer.hs +0/−319
• src/Control/Monad/Hefty/Concurrent/Timer.hs +62/−0
• src/Control/Monad/Hefty/Coroutine.hs +13/−0
• src/Control/Monad/Hefty/Except.hs +70/−0
• src/Control/Monad/Hefty/Fail.hs +17/−0
• src/Control/Monad/Hefty/Fresh.hs +28/−0
• src/Control/Monad/Hefty/Input.hs +41/−0
• src/Control/Monad/Hefty/KVStore.hs +43/−0
• src/Control/Monad/Hefty/NonDet.hs +112/−0
• src/Control/Monad/Hefty/Output.hs +51/−0
• src/Control/Monad/Hefty/Provider.hs +97/−0
• src/Control/Monad/Hefty/Reader.hs +51/−0
• src/Control/Monad/Hefty/Resource.hs +36/−0
• src/Control/Monad/Hefty/ShiftReset.hs +47/−0
• src/Control/Monad/Hefty/State.hs +93/−0
• src/Control/Monad/Hefty/Unlift.hs +23/−0
• src/Control/Monad/Hefty/Writer.hs +97/−0
• test/Driver.hs +1/−3
• test/Test/Coroutine.hs +24/−0
• test/Test/Pyth.hs +33/−0
• test/Test/Semantics.hs +89/−0
• test/Test/Writer.hs +36/−0

@@ -15,3 +15,9 @@ * Simplify the logging example. * Update the data-effects version to 0.1.1. * Rename the module from `Control.Effect.Handler` to `Control.Effect.Interpreter` to align with terminology.++## 0.4.0.0 -- 2024-10-10++* 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.

@@ -7,13 +7,20 @@  module Main where -import Control.Effect (type (~>))-import Control.Effect.ExtensibleChurch (runEff, type (:!!))-import Control.Effect.Hefty (Elab, interposeK, interpretRec, interpretRecH)-import Control.Monad.IO.Class (liftIO)-import Data.Effect.TH (makeEffectF, makeEffectH)-import Data.Function ((&))-import Data.Hefty.Extensible (ForallHFunctor, type (<|))+import Control.Monad.Hefty (+    interposeBy,+    interpret,+    interpretH,+    liftIO,+    makeEffectF,+    makeEffectH,+    runEff,+    (&),+    type (:!!),+    type (<|),+    type (~>),+    type (~~>),+ )  type ForkID = Int @@ -21,16 +28,16 @@     Fork :: Fork ForkID makeEffectF [''Fork] -runForkSingle :: ForallHFunctor eh => eh :!! LFork ': r ~> eh :!! r-runForkSingle = interpretRec \Fork -> pure 0+runForkSingle :: eh :!! Fork ': r ~> eh :!! r+runForkSingle = interpret \Fork -> pure 0  data ResetFork f a where-    ResetFork :: Monoid w => f w -> ResetFork f w+    ResetFork :: (Monoid w) => f w -> ResetFork f w makeEffectH [''ResetFork] -applyResetFork :: Fork <| r => Int -> Elab ResetFork ('[] :!! r)+applyResetFork :: (Fork <| r) => Int -> ResetFork ~~> '[] :!! r applyResetFork numberOfFork (ResetFork m) =-    m & interposeK pure \resume Fork -> do+    m & interposeBy pure \Fork resume -> do         r <- mapM resume [1 .. numberOfFork]         pure $ mconcat r @@ -38,7 +45,7 @@ main =     runEff         . runForkSingle-        . interpretRecH (applyResetFork 4)+        . interpretH (applyResetFork 4)         $ do             liftIO . putStrLn . (("[out of scope] " ++) . show) =<< fork             s <- resetFork do

@@ -4,22 +4,29 @@  module Main where -import Control.Arrow ((>>>))-import Control.Effect.ExtensibleChurch (runEff, type (!!))-import Control.Effect.Hefty (send1, unkeyEff, type ($))-import Control.Effect.Interpreter.Heftia.Reader (runAsk, runLocal)-import Control.Effect.Interpreter.Heftia.ShiftReset (evalShift, runShift_)-import Control.Effect.Interpreter.Heftia.State (evalState) import Control.Effect.Key (key) import Control.Monad.Extra (whenM)-import Control.Monad.IO.Class (liftIO)-import Data.Effect.HFunctor ((:+:))+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, Shift_, getCC, getCC_)+import Data.Effect.ShiftReset (Shift_, getCC, getCC_) import Data.Effect.State (State, get'', modify)-import Data.Free.Sum (type (+))-import Data.Function ((&)) import Data.Functor ((<&>))  main :: IO ()@@ -64,35 +71,37 @@ handleReaderThenShift :: IO () handleReaderThenShift =     prog-        & runLocal-        & runAsk 1+        & runReader 1         & runEff         & evalShift-        & (unkeyEff >>> evalState 0)+        & (evalState 0 . unkey)         & runEff   where-    prog :: Local Int !! Ask Int + Shift () !! "counter" #> State Int + IO $ ()+    prog+        :: (r ~ '["counter" #> State Int, IO])+        => Eff '[Local Int] '[Ask Int, Eff '[ShiftFix () '[] r] r] ()     prog = do-        k <- send1 getCC+        k <- sendN @1 $ getCC         env <- ask @Int-        send1 $ liftIO $ putStrLn $ "[local scope outer] env = " ++ show env+        sendN @1 $ liftIO $ putStrLn $ "[local scope outer] env = " ++ show env         local @Int (* 2) do-            whenM (send1 (get'' @"counter") <&> (< 5)) do-                send1 $ modify (+ 1) & key @"counter"+            whenM (sendN @1 (get'' @"counter") <&> (< 5)) do+                sendN @1 $ modify (+ 1) & key @"counter"                 env' <- ask @Int-                send1 $ liftIO $ putStrLn $ "[local scope inner] env = " ++ show env'-                send1 k+                sendN @1 $ liftIO $ putStrLn $ "[local scope inner] env = " ++ show env'+                send $ unShiftBase k  handleShiftThenReader :: IO () handleShiftThenReader = do     prog         & runShift_-        & runLocal-        & runAsk 1-        & (unkeyEff >>> evalState 0)+        & runReader 1+        & (evalState 0 . unkey)         & runEff   where-    prog :: Shift_ :+: Local Int !! Ask Int + "counter" #> State Int + IO $ ()+    prog+        :: (r ~ (Ask Int + "counter" #> State Int + IO))+        => Shift_ (Local Int !! r) :+: Local Int !! r $ ()     prog = do         k <- getCC_         env <- ask @Int@@ -102,4 +111,4 @@                 modify (+ 1) & key @"counter"                 env' <- ask @Int                 liftIO $ putStrLn $ "[local scope inner] env = " ++ show env'-                k+                raiseH k

@@ -0,0 +1,68 @@+{-# LANGUAGE AllowAmbiguousTypes #-}+{-# LANGUAGE TemplateHaskell #-}++-- SPDX-License-Identifier: MPL-2.0++module Main where++import Control.Arrow ((>>>))+import Control.Monad.Hefty (+    Eff,+    Type,+    interpret,+    interpretH,+    liftIO,+    makeEffect,+    runEff,+    type (<|),+    type (~>),+ )+import Control.Monad.Hefty.Provider (ProviderFix_, provide_, runProvider_)++data FileSystemF a where+    ReadFS :: FilePath -> FileSystemF String+    WriteFS :: FilePath -> String -> FileSystemF ()++data FileSystemH m (a :: Type) where+    TransactFS :: m a -> FileSystemH m a+makeEffect [''FileSystemF] [''FileSystemH]++type FSProvider eh ef = ProviderFix_ FilePath FileSystemH eh FileSystemF ef++runDummyFSProvider :: (IO <| ef) => Eff (FSProvider eh ef ': eh) ef ~> Eff eh ef+runDummyFSProvider =+    runProvider_ \workDir ->+        interpretH \case+            TransactFS m -> do+                liftIO $ putStrLn $ "[DUMMY FS " <> workDir <> "] START TRANSACTION"+                r <- m+                liftIO $ putStrLn $ "[DUMMY FS " <> workDir <> "] END TRANSACTION"+                pure r+            >>> interpret \case+                ReadFS path -> do+                    liftIO $ putStrLn $ "[DUMMY FS " <> workDir <> "] readFS " <> show path+                    pure $ "DUMMY CONTENT on " <> workDir <> path+                WriteFS path s -> do+                    liftIO $ putStrLn $ "[DUMMY FS " <> workDir <> "] writeFS " <> show path <> " " <> show s++main :: IO ()+main =+    runEff . runDummyFSProvider $+        provide_ @"fs1" "/fs1" \_ -> do+            provide_ @"fs2" "/fs2" \inBase -> do+                inBase do+                    s1 <- readFS' @"fs1" "/a/b/c"+                    liftIO $ putStrLn $ "content: " <> show s1+                    writeFS' @"fs1" "/d/e/f" "foobar"++                liftIO $ putStrLn "-----"++                s2 <- readFS' @"fs2" "/a/b/c"+                liftIO $ putStrLn $ "content: " <> show s2+                writeFS' @"fs2" "/d/e/f" "foobar"++                liftIO $ putStrLn "-----"++                transactFS' @"fs2" do+                    inBase $ transactFS' @"fs1" do+                        liftIO $ print "hello"

@@ -7,14 +7,20 @@  module Main where -import Control.Effect (type (~>))-import Control.Effect.ExtensibleChurch (runEff, type (:!!))-import Control.Effect.Hefty (interposeRec, interpretRec, unkeyEff)-import Control.Effect.Key (SendInsBy)-import Control.Monad.IO.Class (liftIO)+import Control.Effect.Key (SendFOEBy)+import Control.Monad.Hefty (+    MemberBy,+    interpose,+    interpret,+    liftIO,+    makeEffectF,+    runEff,+    unkey,+    type (:!!),+    type (<|),+    type (~>),+ ) import Data.Effect.Key (unKey, type (#>))-import Data.Effect.TH (makeEffectF)-import Data.Hefty.Extensible (ForallHFunctor, MemberBy, type (<|))  data Teletype a where     ReadTTY :: Teletype String@@ -22,25 +28,25 @@  makeEffectF [''Teletype] -teletypeToIO :: (IO <| r, ForallHFunctor eh) => eh :!! LTeletype ': r ~> eh :!! r-teletypeToIO = interpretRec \case+teletypeToIO :: (IO <| r) => eh :!! Teletype ': r ~> eh :!! r+teletypeToIO = interpret \case     ReadTTY -> liftIO getLine     WriteTTY msg -> liftIO $ putStrLn msg -echo :: (SendInsBy "tty1" Teletype m, Monad m) => m ()+echo :: (SendFOEBy "tty1" Teletype m, Monad m) => m () echo = do     i <- readTTY'' @"tty1"     case i of         "" -> pure ()         _ -> writeTTY'' @"tty1" i >> echo -strong :: (MemberBy "tty1" Teletype ef, ForallHFunctor eh) => eh :!! ef ~> eh :!! ef+strong :: (MemberBy "tty1" Teletype ef) => eh :!! ef ~> eh :!! ef strong =-    interposeRec @("tty1" #> _) \e -> case unKey e of+    interpose @("tty1" #> _) \e -> case unKey e of         ReadTTY -> readTTY'' @"tty1"         WriteTTY msg -> writeTTY'' @"tty1" $ msg <> "!"  main :: IO () main = runEff do     liftIO $ putStrLn "Please enter something..."-    teletypeToIO . unkeyEff @"tty1" . strong . strong $ echo+    teletypeToIO . unkey @"tty1" . strong . strong $ echo

@@ -9,31 +9,38 @@ module Main where  import Control.Arrow ((>>>))-import Control.Effect (type (<:), type (<<:), type (~>))-import Control.Effect.ExtensibleFinal (runEff, type (!!), type (:!!))-import Control.Effect.Hefty (-    Elab,-    interposeRec,-    interposeRecH,-    interpretRec,-    interpretRecH,+import Control.Monad (when)+import Control.Monad.Hefty (+    Type,+    interpose,+    interposeH,+    interpret,+    interpretH,+    liftIO,+    makeEffectF,+    makeEffectH,     raise,     raiseH,     raiseUnder,-    reinterpretRecH,+    reinterpretH,+    runEff,     subsume,+    (&),+    type (!!),+    type (+),+    type (:!!),+    type (<:),+    type (<<:),+    type (<<|),+    type (<|),+    type (~>),+    type (~~>),  )-import Control.Effect.Interpreter.Heftia.Reader (runReader)-import Control.Effect.Interpreter.Heftia.State (evalState)-import Control.Monad (when)-import Control.Monad.IO.Class (MonadIO, liftIO)-import Data.Effect.Reader (LAsk, Local, ask, local)+import Control.Monad.Hefty.Reader (runReader)+import Control.Monad.Hefty.State (evalState)+import Control.Monad.IO.Class (MonadIO)+import Data.Effect.Reader (Ask, Local, ask, local) import Data.Effect.State (get, modify)-import Data.Effect.TH (makeEffectF, makeEffectH)-import Data.Free.Sum (type (+))-import Data.Function ((&))-import Data.Hefty.Extensible (ForallHFunctor, type (<<|), type (<|))-import Data.Kind (Type) import Data.Text (Text) import Data.Text qualified as T import Data.Text.IO qualified as T@@ -44,18 +51,18 @@     Logging :: Text -> Log () makeEffectF [''Log] -logToIO :: (IO <| r, ForallHFunctor eh) => eh :!! LLog ': r ~> eh :!! r-logToIO = interpretRec \(Logging msg) -> liftIO $ T.putStrLn msg+logToIO :: (IO <| r) => eh :!! Log ': r ~> eh :!! r+logToIO = interpret \(Logging msg) -> liftIO $ T.putStrLn msg  data Time a where     CurrentTime :: Time UTCTime makeEffectF [''Time] -timeToIO :: (IO <| r, ForallHFunctor eh) => eh :!! LTime ': r ~> eh :!! r-timeToIO = interpretRec \CurrentTime -> liftIO getCurrentTime+timeToIO :: (IO <| r) => eh :!! Time ': r ~> eh :!! r+timeToIO = interpret \CurrentTime -> liftIO getCurrentTime -logWithTime :: (Log <| ef, Time <| ef, ForallHFunctor eh) => eh :!! ef ~> eh :!! ef-logWithTime = interposeRec \(Logging msg) -> do+logWithTime :: (Log <| ef, Time <| ef) => eh :!! ef ~> eh :!! ef+logWithTime = interpose \(Logging msg) -> do     t <- currentTime     logging $ "[" <> iso8601 t <> "] " <> msg @@ -64,47 +71,48 @@  -- | An effect that introduces a scope that represents a chunk of logs. data LogChunk f (a :: Type) where-    LogChunk ::-        -- | chunk name-        Text ->-        f a ->-        LogChunk f a+    LogChunk+        :: Text+        -- ^ chunk name+        -> f a+        -> LogChunk f a  makeEffectH [''LogChunk]  -- | Ignore chunk names and output logs in log chunks as they are.-runLogChunk :: ForallHFunctor eh => LogChunk ': eh :!! ef ~> eh :!! ef-runLogChunk = interpretRecH \(LogChunk _ m) -> m+runLogChunk :: LogChunk ': eh :!! ef ~> eh :!! ef+runLogChunk = interpretH \(LogChunk _ m) -> m  data FileSystem a where     Mkdir :: FilePath -> FileSystem ()     WriteToFile :: FilePath -> Text -> FileSystem () makeEffectF [''FileSystem] -runDummyFS :: (IO <| r, ForallHFunctor eh) => eh :!! LFileSystem ': r ~> eh :!! r-runDummyFS = interpretRec \case+runDummyFS :: (IO <| r) => eh :!! FileSystem ': r ~> eh :!! r+runDummyFS = interpret \case     Mkdir path ->         liftIO $ putStrLn $ "<runDummyFS> mkdir " <> path     WriteToFile path content ->         liftIO $ putStrLn $ "<runDummyFS> writeToFile " <> path <> " : " <> T.unpack content  -- | Create directories according to the log-chunk structure and save one log in one file.-saveLogChunk ::-    forall eh ef.-    (LogChunk <<| eh, Log <| ef, FileSystem <| ef, Time <| ef, ForallHFunctor eh) =>-    eh :!! ef ~> eh :!! ef+saveLogChunk+    :: forall eh ef+     . (LogChunk <<| eh, Log <| ef, FileSystem <| ef, Time <| ef)+    => eh :!! ef ~> eh :!! ef saveLogChunk =-    raise >>> raiseH+    raise+        >>> raiseH         >>> hookCreateDirectory         >>> hookWriteFile         >>> runReader @FilePath "./log/"   where     hookCreateDirectory-        , hookWriteFile ::-            (Local FilePath ': eh :!! LAsk FilePath ': ef)-                ~> (Local FilePath ': eh :!! LAsk FilePath ': ef)+        , hookWriteFile+            :: (Local FilePath ': eh :!! Ask FilePath ': ef)+                ~> (Local FilePath ': eh :!! Ask FilePath ': ef)     hookCreateDirectory =-        interposeRecH \(LogChunk chunkName a) -> logChunk chunkName do+        interposeH \(LogChunk chunkName a) -> logChunk chunkName do             chunkBeginAt <- currentTime             let dirName = T.unpack $ iso8601 chunkBeginAt <> "-" <> chunkName             local @FilePath (++ dirName ++ "/") do@@ -113,25 +121,25 @@                 a      hookWriteFile =-        interposeRec \(Logging msg) -> do+        interpose \(Logging msg) -> do             logChunkPath <- ask             logAt <- currentTime             writeToFile (T.unpack $ T.pack logChunkPath <> iso8601 logAt <> ".log") msg             logging msg  -- | Limit the number of logs in a log chunk to the first @n@ logs.-limitLogChunk :: Log <| ef => Int -> '[LogChunk] :!! LLog ': ef ~> '[LogChunk] :!! LLog ': ef-limitLogChunk n = reinterpretRecH $ elabLimitLogChunk n+limitLogChunk :: (Log <| ef) => Int -> '[LogChunk] :!! Log ': ef ~> '[LogChunk] :!! Log ': ef+limitLogChunk n = reinterpretH $ elabLimitLogChunk n -elabLimitLogChunk :: Log <| ef => Int -> Elab LogChunk ('[LogChunk] :!! LLog ': ef)+elabLimitLogChunk :: (Log <| ef) => Int -> LogChunk ~~> '[LogChunk] :!! Log ': ef elabLimitLogChunk n (LogChunk name a) =     logChunk name do         raise . raiseH $ limitLog $ runLogChunk $ limitLogChunk n a   where-    limitLog :: Log <| ef => '[] :!! LLog ': ef ~> '[] :!! ef+    limitLog :: (Log <| ef) => '[] :!! Log ': ef ~> '[] :!! ef     limitLog a' =         evalState @Int 0 $-            raiseUnder a' & interpretRec \(Logging msg) -> do+            raiseUnder a' & interpret \(Logging msg) -> do                 count <- get                 when (count < n) do                     logging msg@@ -173,14 +181,14 @@     logExample         & saveLogChunk         & limitLogChunk 2-        & subsume @LLog+        & subsume @Log         & runApp  limitThenSave :: IO () limitThenSave =     logExample         & limitLogChunk 2-        & subsume @LLog+        & subsume @Log         & saveLogChunk         & runApp 

@@ -1,3 +1,6 @@+{-# LANGUAGE AllowAmbiguousTypes #-}+{-# LANGUAGE TemplateHaskell #-}+ -- 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/.@@ -10,18 +13,25 @@ module Main where  import Control.Applicative ((<|>))-import Control.Effect.ExtensibleChurch ((:!!))-import Control.Effect.Hefty (runPure, type ($))-import Control.Effect.Interpreter.Heftia.Except (runCatch, runThrow)-import Control.Effect.Interpreter.Heftia.NonDet (runChooseH, runNonDet)-import Control.Effect.Interpreter.Heftia.State (evalState)-import Control.Effect.Interpreter.Heftia.Writer (elaborateWriterPre, runTell)+import Control.Monad.Hefty (+    interpret,+    makeEffectF,+    runPure,+    type ($),+    type (:!!),+    type (<<|),+    type (<|),+    type (~>),+ )+import Control.Monad.Hefty.Except (runCatch, runThrow)+import Control.Monad.Hefty.NonDet (runChooseH, runNonDet)+import Control.Monad.Hefty.State (evalState)+import Control.Monad.Hefty.Writer (runTell, runWriterHPre) import Data.Effect.Except (Catch, Throw, catch, throw) import Data.Effect.NonDet (ChooseH, Empty) import Data.Effect.State (State, get, put) import Data.Effect.Writer (Tell, WriterH, listen, tell) import Data.Functor (($>))-import Data.Hefty.Extensible (type (<<|), type (<|)) import Data.Monoid (Sum (Sum))  statePlusExcept :: IO ()@@ -39,74 +49,103 @@ nonDetPlusExcept :: IO () nonDetPlusExcept = do     let action1-            , action2 ::-                (Empty <| ef, ChooseH <<| eh, Throw () <| ef, Catch () <<| eh) => eh :!! ef $ Bool+            , action2+                :: (Empty <| ef, ChooseH <<| eh, Throw () <| ef, Catch () <<| eh) => eh :!! ef $ Bool         action1 = (pure True <|> throw ()) `catch` \() -> pure False         action2 = (throw () <|> pure True) `catch` \() -> pure False -        testAllPattern ::-            ( forall eh ef.-              (Empty <| ef, ChooseH <<| eh, Throw () <| ef, Catch () <<| eh) =>-              (eh :!! ef) Bool-            ) ->-            String ->-            IO ()+        testAllPattern+            :: ( forall eh ef+                  . (Empty <| ef, ChooseH <<| eh, Throw () <| ef, Catch () <<| eh)+                 => (eh :!! ef) Bool+               )+            -> String+            -> IO ()         testAllPattern action name = do             putStr $ "( runNonDet . runThrow . runCatch . runChooseH $ " <> name <> " ) = "             print . runPure $-                runNonDet @[] . runThrow @() . runCatch @() . runChooseH $ action+                runNonDet @[] . runThrow @() . runCatch @() . runChooseH $+                    action              putStr $ "( runThrow . runNonDet . runCatch . runChooseH $ " <> name <> " ) = "             print . runPure $-                runThrow @() . runNonDet @[] . runCatch @() . runChooseH $ action+                runThrow @() . runNonDet @[] . runCatch @() . runChooseH $+                    action      testAllPattern action1 "action1"     testAllPattern action2 "action2"  nonDetPlusWriter :: IO () nonDetPlusWriter = do-    let action ::-            (Empty <| ef, ChooseH <<| eh, Tell (Sum Int) <| ef, WriterH (Sum Int) <<| eh) =>-            eh :!! ef $ (Sum Int, Bool)+    let action+            :: (Empty <| ef, ChooseH <<| eh, Tell (Sum Int) <| ef, WriterH (Sum Int) <<| eh)+            => eh :!! ef $ (Sum Int, Bool)         action = listen $ add 1 *> (add 2 $> True <|> add 3 $> False)           where             add = tell . Sum @Int -    putStr "( runNonDet . runTell . elaborateWriter . runChooseH $ action ) = "+    putStr "( runNonDet . runTell . runWriterH . runChooseH $ action ) = "     print . map (\(Sum m, (Sum n, b)) -> (m, (n, b))) . runPure $-        runNonDet @[] . runTell @(Sum Int) . elaborateWriterPre @(Sum Int) . runChooseH $ action+        runNonDet @[] . runTell @(Sum Int) . runWriterHPre @(Sum Int) . runChooseH $+            action -    putStr "( runTell . runNonDet . elaborateWriter . runChooseH $ action ) = "+    putStr "( runTell . runNonDet . runWriterH . runChooseH $ action ) = "     print . (\(Sum m, xs) -> (m, map (\(Sum n, b) -> (n, b)) xs)) . runPure $-        runTell @(Sum Int) . runNonDet @[] . elaborateWriterPre @(Sum Int) . runChooseH $ action+        runTell @(Sum Int) . runNonDet @[] . runWriterHPre @(Sum Int) . runChooseH $+            action +data SomeEff a where+    SomeAction :: SomeEff String+makeEffectF [''SomeEff]++theIssue12 :: IO ()+theIssue12 = do+    let action :: (Catch String <<| eh, Throw String <| ef, SomeEff <| ef) => eh :!! ef $ String+        action = someAction `catch` \(_ :: String) -> pure "caught"++        runSomeEff :: (Throw String <| ef) => eh :!! SomeEff ': ef ~> eh :!! ef+        runSomeEff = interpret \SomeAction -> throw "not caught"++    putStr "interpret SomeEff then runCatch : ( runThrow . runCatch . runSomeEff $ action ) = "+    print $ runPure $ runThrow @String . runCatch @String . runSomeEff $ action++    putStr "runCatch then interpret SomeEff : ( runThrow . runSomeEff . runCatch $ action ) = "+    print $ runPure $ runThrow @String . runSomeEff . runCatch @String $ action+ main :: IO () main = do-    putStrLn "# State + Except"+    putStrLn "# State & Except"     statePlusExcept -    putStrLn "\n# NonDet + Except"+    putStrLn "\n# NonDet & Except"     nonDetPlusExcept -    putStrLn "\n# NonDet + Writer"+    putStrLn "\n# NonDet & Writer"     nonDetPlusWriter +    putStrLn "\n# https://github.com/hasura/eff/issues/12"+    theIssue12+     putStrLn "\n[Note] All other permutations will cause type errors."  {--# State + Except+# State & Except ( evalState . runThrow . runCatch $ action ) = Right True ( runThrow . evalState . runCatch $ action ) = Right True -# NonDet + Except+# 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] -# NonDet + Writer-( runNonDet . runTell . elaborateWriter . runChooseH $ action ) = [(3,(3,True)),(4,(4,False))]-( runTell . runNonDet . elaborateWriter . runChooseH $ action ) = (6,[(3,True),(4,False)])+# NonDet & Writer+( runNonDet . runTell . runWriterH . runChooseH $ action ) = [(3,(3,True)),(4,(4,False))]+( runTell . runNonDet . runWriterH . runChooseH $ action ) = (6,[(3,True),(4,False)])++# 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"  [Note] All other permutations will cause type errors. -}

@@ -11,13 +11,19 @@ -} module Main where -import Control.Effect (type (<:), type (~>))-import Control.Effect.ExtensibleChurch (runEff, type (:!!))-import Control.Effect.Hefty (interposeRec, interpretRec, untagEff)-import Control.Monad.IO.Class (liftIO)-import Data.Effect.TH (makeEffectF)+import Control.Monad.Hefty (+    interpose,+    interpret,+    liftIO,+    makeEffectF,+    runEff,+    untag,+    type (:!!),+    type (<:),+    type (<|),+    type (~>),+ ) import Data.Effect.Tag (Tag (unTag), type (#))-import Data.Hefty.Extensible (ForallHFunctor, type (<|))  data Teletype a where     ReadTTY :: Teletype String@@ -25,8 +31,8 @@  makeEffectF [''Teletype] -teletypeToIO :: (IO <| r, ForallHFunctor eh) => eh :!! LTeletype ': r ~> eh :!! r-teletypeToIO = interpretRec \case+teletypeToIO :: (IO <| r) => eh :!! Teletype ': r ~> eh :!! r+teletypeToIO = interpret \case     ReadTTY -> liftIO getLine     WriteTTY msg -> liftIO $ putStrLn msg @@ -37,13 +43,13 @@         "" -> pure ()         _ -> writeTTY' @"tty1" i >> echo -strong :: (Teletype # "tty1" <| ef, ForallHFunctor eh) => eh :!! ef ~> eh :!! ef+strong :: (Teletype # "tty1" <| ef) => eh :!! ef ~> eh :!! ef strong =-    interposeRec @(_ # "tty1") \e -> case unTag e of+    interpose @(_ # "tty1") \e -> case unTag e of         ReadTTY -> readTTY' @"tty1"         WriteTTY msg -> writeTTY' @"tty1" $ msg <> "!"  main :: IO () main = runEff do     liftIO $ putStrLn "Please enter something..."-    teletypeToIO . untagEff @"tty1" . strong . strong $ echo+    teletypeToIO . untag @"tty1" . strong . strong $ echo

@@ -4,11 +4,8 @@  module Main where -import Control.Effect (type (<:), type (<<:))-import Control.Effect.ExtensibleChurch (runEff)-import Control.Effect.Hefty (interpretRecH)-import Control.Effect.Interpreter.Heftia.Writer (elabWriterPost, elabWriterPre, runTell)-import Control.Monad.IO.Class (liftIO)+import Control.Monad.Hefty (liftIO, runEff, type (<:), type (<<:))+import Control.Monad.Hefty.Writer (runTell, runWriterHPost, runWriterHPre) import Data.Effect.Writer (Tell, WriterH, censor, tell)  hello :: (Tell String <: m, Monad m) => m ()@@ -33,12 +30,12 @@ main = runEff do     (sPre, _) <-         runTell-            . interpretRecH (elabWriterPre @String)+            . runWriterHPre @String             $ censorHello      (sPost, _) <-         runTell-            . interpretRecH (elabWriterPost @String)+            . runWriterHPost @String             $ censorHello      liftIO $ putStrLn $ "Pre-applying: " <> sPre

@@ -3,22 +3,26 @@ [![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) -Heftia is a higher-order effects version of Freer.+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.+In its generalization, the focus is on ensuring predictable results based on simple, consistent semantics, while preserving soundness. -This library provides "[continuation-based semantics](https://github.com/lexi-lambda/eff/blob/master/notes/semantics-zoo.md)" for higher-order effects, the same as [lexi-lambda's eff](https://github.com/lexi-lambda/eff).-Instead of using the `IO` monad to implement delimited continuations for effects, Heftia internally uses `Freer` monad.+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 paper+The library allows the following effects with well-defined semantics:++* Coroutines+* Non-deterministic computations+* `MonadUnliftIO`++This library is inspired by the paper: * Casper Bach Poulsen and Cas van der Rest. 2023. Hefty Algebras: Modular     Elaboration of Higher-Order Algebraic Effects. Proc. ACM Program. Lang. 7,     POPL, Article 62 (January 2023), 31 pages. <https://doi.org/10.1145/3571255> -inspires this library.-Hefty trees, proposed by the above paper, are extensions of free monads,-allowing for a straightforward treatment of higher-order effects.+The *elaboration* approach proposed in the above paper allows for a straightforward treatment of higher-order effects. -This library offers Hefty monads and Freer monads, encoded into data-types in several ways to enable tuning in pursuit of high performance.+Heftia's data structure is an extension of the Freer monad, designed to be theoretically straightforward by eliminating ad-hoc elements.  ## Status @@ -27,12 +31,12 @@  **We are looking forward to your feedback!** -## Installation+## Getting Started 1.     ```console     $ cabal update     ```-2. Add `heftia-effects ^>= 0.2` and `ghc-typelits-knownnat ^>= 0.7` to the build dependencies. Enable the [ghc-typelits-knownnat](https://hackage.haskell.org/package/ghc-typelits-knownnat) plugin, `GHC2021`, and the following language extensions as needed:+2. Add `heftia-effects ^>= 0.4` and `ghc-typelits-knownnat ^>= 0.7` to the build dependencies. Enable the [ghc-typelits-knownnat](https://hackage.haskell.org/package/ghc-typelits-knownnat) plugin, `GHC2021`, and the following language extensions as needed:      * `LambdaCase`     * `DerivingStrategies`@@ -50,7 +54,7 @@ ...     build-depends:         ...-        heftia-effects ^>= 0.2,+        heftia-effects ^>= 0.4,         ghc-typelits-knownnat ^>= 0.7,      default-language: GHC2021@@ -74,33 +78,11 @@ ... ``` -This library has been tested to work with GHC 9.2.8.+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-To run the [SemanticsZoo example](https://github.com/sayo-hs/heftia/blob/v0.3.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 -# 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]--# NonDet + Writer-( runNonDet . runTell . elaborateWriter . runChooseH $ action ) = [(3,(3,True)),(4,(4,False))]-( runTell . runNonDet . elaborateWriter . runChooseH $ action ) = (6,[(3,True),(4,False)])--[Note] All other permutations will cause type errors.-$-```- ## Example  Compared to existing Effect System libraries in Haskell that handle higher-order effects, this@@ -110,9 +92,8 @@ ### Extracting Multi-shot Delimited Continuations  In handling higher-order effects, it's easy to work with **multi-shot delimited continuations**.-This enables an almost complete emulation of "Algebraic Effects and Handlers". For more details, please refer to-the [example code](https://github.com/sayo-hs/heftia/blob/v0.3.0/heftia-effects/Example/Continuation/Main.hs).+the [example code](https://github.com/sayo-hs/heftia/blob/v0.4.0/heftia-effects/Example/Continuation/Main.hs).  ### Two interpretations of the `censor` effect for Writer @@ -147,12 +128,12 @@ main = runEff do     (sPre, _) <-         runTell-            . interpretRecH (elabWriterPre @String)+            . runWriterHPre @String             $ censorHello      (sPost, _) <-         runTell-            . interpretRecH (elabWriterPost @String)+            . runWriterHPost @String             $ censorHello      liftIO $ putStrLn $ "Pre-applying: " <> sPre@@ -165,21 +146,43 @@ Post-applying: Hello world!! ``` -For more details, please refer to the [complete code](https://github.com/sayo-hs/heftia/blob/v0.3.0/heftia-effects/Example/Writer/Main.hs) and the [implementation of the elaborator](https://github.com/sayo-hs/heftia/blob/v0.3.0/heftia-effects/src/Control/Effect/Interpreter/Heftia/Writer.hs).+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). -Furthermore, the structure of Heftia is theoretically straightforward, with ad-hoc elements being-eliminated.+### 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 -Additionally, Heftia supports not only monadic effectful programs but also **applicative effectful programs**.-This may be useful when writing concurrent effectful code.+# 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] -Heftia is the current main focus of the [Sayo Project](https://github.com/sayo-hs).+# NonDet & Writer+( runNonDet . runTell . runWriterH . runChooseH $ action ) = [(3,(3,True)),(4,(4,False))]+( runTell . runNonDet . runWriterH . runChooseH $ action ) = (6,[(3,True),(4,False)]) +# 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"++[Note] All other permutations will cause type errors.+$+```+ ## Documentation-The example codes are located in the [heftia-effects/Example/](https://github.com/sayo-hs/heftia/tree/v0.3.0/heftia-effects/Example) directory.-Also, the following *HeftWorld* example: https://github.com/sayo-hs/HeftWorld+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.+Also, the following *HeftWorld* example (outdated): https://github.com/sayo-hs/HeftWorld -Examples with explanations in Japanese can be found in the [docs-ja/examples/](https://github.com/sayo-hs/heftia/tree/v0.3.0/docs-ja/examples) directory.+About the internal *elaboration* mechanism: https://sayo-hs.github.io/jekyll/update/2024/09/04/how-the-heftia-extensible-effects-library-works.html  ## Comparison @@ -193,34 +196,35 @@  * Semantics: Classification of behaviors resulting from the interpretation of effects. -    * continuation-based: The same as Algebraic Effects and Handlers.-    * IO-based: IO + Reader pattern.-    * carrier dependent: The behavior depends on the specific type inference result of the monad. Tagless-final style.--* Performance: Time complexity or space complexity.+    * Algebraic Effects: The same as Algebraic Effects and Handlers.+    * IO-fused: IO + ReaderT pattern.+    * Carrier dependent: The behavior depends on the specific type inference result of the monad. Tagless-final style. -| Library or Language | Higher-Order Effects | Delimited Continuation | Effect System | Purely Monadic                    | Dynamic Effect Rewriting | Semantics                        | Performance (TODO) |-| ------------------- | -------------------- | ---------------------- | --------------| --------------------------------- | ------------------------ | -------------------------------- | ------------------ |-| Heftia              | Yes                  | Multi-shot             | Yes           | Yes (also Applicative and others) | Yes                      | continuation-based               | ?                  |-| freer-simple        | No                   | Multi-shot             | Yes           | Yes                               | Yes                      | continuation-based               | ?                  |-| Polysemy            | Yes                  | No                     | Yes           | Yes                               | Yes                      | weaving-based (functorial state) | ?                  |-| Effectful           | Yes                  | No                     | Yes           | No (based on the `IO` monad)      | Yes                      | IO-based                         | ?                  |-| eff                 | Yes                  | Multi-shot?            | Yes           | No (based on the `IO` monad)      | Yes                      | continuation-based (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 [^2]              | Multi-shot             | Yes           | No (language built-in)            | Yes                      | continuation-based               | ?                  |-| OCaml-lang 5        | ?                    | One-shot               | No [^3]       | No (language built-in)            | ?                        | continuation-based?              | ?                  |+| Library or Language | Higher-Order Effects | Delimited Continuation | Effect System | Purely Monadic                    | Dynamic Effect Rewriting | Semantics                        |+| ------------------- | -------------------- | ---------------------- | --------------| --------------------------------- | ------------------------ | -------------------------------- |+| `heftia`            | Yes                  | Multi-shot             | Yes           | Yes                               | Yes                      | Algebraic Effects                |+| `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                         |+| `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?               | -[^2]: https://gist.github.com/ymdryo/6fb2f7f4020c6fcda98ccc67c090dc75 [^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. This is indeed true in terms of its internal mechanisms as well. -Additionally, this library provides a consistent *continuation-based* semantics that is independent of carriers and effects.-On the other hand, in libraries like in-other-words, mtl, and fused-effects, the semantics of the code depend on the effect and, in part, the carrier inferred by type inference.-Fixing the semantics to a *continuation-based* model helps improve the predictability of the behavior (interpretation result) of the code.+Additionally, this library provides a consistent algebraic effects semantics that is independent of carriers and effects.+On the other hand, in libraries like `in-other-words`, `mtl`, and `fused-effects`, the semantics of the code depend on the effect and, in part, the carrier inferred by type inference.+Fixing the semantics to a algebraic effects model helps improve the predictability of the behavior (interpretation result) of the code without losing flexibility.  Carrier-dependent semantics can lead to unexpected behavior for code readers, particularly in situations where the types become implicit. Particularly, attention should be given to the fact that due to type inference, semantic changes may propagate beyond the blocks enclosed by `interpret` or `interpose`.@@ -228,49 +232,65 @@ Instead, they function as traditional functions, simply transforming the content of the data structure. This results in minimal surprise to the mental model of the code reader. -### Compatibility with other libraries-#### Representation of effects-* Heftia Effects relies on [data-effects](https://github.com/sayo-hs/data-effects) for the definitions of standard effects such as `Reader`, `Writer`, and `State`.+### Performance -* It is generally recommended to use effects defined with automatic derivation provided by [data-effects-th](https://github.com/sayo-hs/data-effects/tree/develop/data-effects-th).+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. -* 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](https://github.com/sayo-hs/data-effects).+For more details, please refer to [performance.md](https://github.com/sayo-hs/heftia/blob/v0.4.0/benchmark/performance.md). -* GADTs for higher-order effects 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 for convenient usage.-    While it is still possible to use them without being instances of `HFunctor`,-    the `interpretRec` family of functions cannot be used when higher-order effects that are not `HFunctor` are unelaborated.-    If this issue is not a concern, the GADT representation of higher-order effects is compatible with Polysemy and fused-effects.-    It is not compatible with Effectful and eff.+### Compatibility with other libraries  #### 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`, 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).+* 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). -## Future Plans-* Enriching the documentation and tests-* Completing missing definitions such as-    * more patterns of interpret & transform function-families.-    * interpreters for the `Accum` and others effect classes+#### 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`. -    and others.-* Benchmarking+* 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.+    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,+    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.++## Future Plans+* Support for Applicative effects+* Completing lacking definitions such as+    * interpreters for the `Accum` and others effects+ ## License-The license is MPL 2.0. Please refer to the [NOTICE](https://github.com/sayo-hs/heftia/blob/v0.3.0/NOTICE).-Additionally, this README.md and the documents under the `docs-ja` directory are licensed-under CC BY-SA 4.0.+The license is MPL 2.0. Please refer to the [NOTICE](https://github.com/sayo-hs/heftia/blob/v0.4.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.3.0/CONTRIBUTING.md).+Please see [CONTRIBUTING.md](https://github.com/sayo-hs/heftia/blob/v0.4.0/CONTRIBUTING.md). -## Credits-Parts of this project have been inspired by the following resources:+## 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: -* **[Hefty Algebras -- The Artifact](https://github.com/heft-lang/POPL2023)**-    * **Copyright** (c) 2023 Casper Bach Poulsen and Cas van der Rest-    * **License**: MIT+- Oleg Kiselyov, Amr Sabry, and Cameron Swords — [Extensible Effects: An alternative to monad transfomers][oleg:exteff]+- Oleg Kiselyov and Hiromi Ishii — [Freer Monads, More Extensible Effects][oleg:more]+- Rob Rix, Patrick Thomson, and other contributors — [`fused-effects`][gh:fused-effects]+- 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]++[gh:fused-effects]: https://github.com/fused-effects/fused-effects+[gh:polysemy]: https://github.com/polysemy-research/polysemy+[oleg:exteff]: http://okmij.org/ftp/Haskell/extensible/exteff.pdf+[oleg:more]: http://okmij.org/ftp/Haskell/extensible/more.pdf+[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

@@ -0,0 +1,115 @@+-- SPDX-License-Identifier: BSD-3-Clause+-- (c) 2022 Xy Ren; 2024 Sayo Koyoneda++-- Benchmarking scoped effects #1: Catching errors++module BenchCatch where++import Control.Carrier.Error.Either qualified as F+import Control.Carrier.Reader qualified as F+import Control.Monad.Except qualified as M+import Control.Monad.Hefty qualified as H+import Control.Monad.Hefty.Except qualified as H+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+import Polysemy qualified as P+import Polysemy.Error qualified as P+import Polysemy.Reader qualified as P+import "eff" Control.Effect qualified as E++programHeftia :: (H.Member (H.Throw ()) ef, H.MemberH (H.Catch ()) eh) => Int -> H.Eff eh ef a+programHeftia = \case+    0 -> H.throw ()+    n -> H.catch (programHeftia (n - 1)) \() -> H.throw ()+{-# NOINLINE programHeftia #-}++catchHeftia :: Int -> Either () ()+catchHeftia n = H.runPure $ H.runThrow $ H.runCatch @() $ programHeftia n++catchHeftiaDeep0, catchHeftiaDeep1, catchHeftiaDeep2, catchHeftiaDeep3, catchHeftiaDeep4, catchHeftiaDeep5 :: Int -> Either () ()+catchHeftiaDeep0 n = H.runPure $ hrun $ hrun $ hrun $ hrun $ hrun $ H.runThrow $ hrun $ hrun $ hrun $ hrun $ hrun $ H.runCatch @() $ programHeftia n+catchHeftiaDeep1 n = H.runPure $ hrun $ hrun $ hrun $ hrun $ hrun $ H.runThrow $ hrun $ hrun $ hrun $ hrun $ H.runCatch @() $ hrun $ programHeftia n+catchHeftiaDeep2 n = H.runPure $ hrun $ hrun $ hrun $ hrun $ hrun $ H.runThrow $ hrun $ hrun $ hrun $ H.runCatch @() $ hrun $ hrun $ programHeftia n+catchHeftiaDeep3 n = H.runPure $ hrun $ hrun $ hrun $ hrun $ hrun $ H.runThrow $ hrun $ hrun $ H.runCatch @() $ hrun $ hrun $ hrun $ programHeftia n+catchHeftiaDeep4 n = H.runPure $ hrun $ hrun $ hrun $ hrun $ hrun $ H.runThrow $ hrun $ H.runCatch @() $ hrun $ hrun $ hrun $ hrun $ programHeftia n+catchHeftiaDeep5 n = H.runPure $ hrun $ hrun $ hrun $ hrun $ hrun $ H.runThrow $ H.runCatch @() $ 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.Error () `P.Member` es) => Int -> P.Sem es a+programSem = \case+    0 -> P.throw ()+    n -> P.catch (programSem (n - 1)) \() -> P.throw ()+{-# NOINLINE programSem #-}++catchSem :: Int -> Either () ()+catchSem n = P.run $ P.runError $ programSem n++catchSemDeep :: Int -> Either () ()+catchSemDeep n = P.run $ run $ run $ run $ run $ run $ P.runError $ run $ run $ run $ run $ run $ programSem n+  where+    run = P.runReader ()++programFused :: (F.Has (F.Error ()) sig m) => Int -> m a+programFused = \case+    0 -> F.throwError ()+    n -> F.catchError (programFused (n - 1)) \() -> F.throwError ()+{-# NOINLINE programFused #-}++catchFused :: Int -> Either () ()+catchFused n = F.run $ F.runError $ programFused n++catchFusedDeep :: Int -> Either () ()+catchFusedDeep n = F.run $ run $ run $ run $ run $ run $ F.runError $ run $ run $ run $ run $ run $ programFused n+  where+    run = F.runReader ()++programEffectful :: (EL.Error () EL.:> es) => Int -> EL.Eff es a+programEffectful = \case+    0 -> EL.throwError ()+    n -> EL.catchError (programEffectful (n - 1)) \_ () -> EL.throwError ()+{-# NOINLINE programEffectful #-}++catchEffectful :: Int -> Either (EL.CallStack, ()) ()+catchEffectful n = EL.runPureEff $ EL.runError $ programEffectful n++catchEffectfulDeep :: Int -> Either (EL.CallStack, ()) ()+catchEffectfulDeep n =+    EL.runPureEff $ run $ run $ run $ run $ run $ EL.runError $ run $ run $ run $ run $ run $ programEffectful n+  where+    run = EL.runReader ()++programEff :: (E.Error () E.:< es) => Int -> E.Eff es a+programEff = \case+    0 -> E.throw ()+    n -> E.catch (programEff (n - 1)) \() -> E.throw ()+{-# NOINLINE programEff #-}++catchEff :: Int -> Either () ()+catchEff n = E.run $ E.runError $ programEff n++catchEffDeep :: Int -> Either () ()+catchEffDeep n = E.run $ run $ run $ run $ run $ run $ E.runError $ run $ run $ run $ run $ run $ programEff n+  where+    run = E.runReader ()++programMtl :: (M.MonadError () m) => Int -> m a+programMtl = \case+    0 -> M.throwError ()+    n -> M.catchError (programMtl (n - 1)) \() -> M.throwError ()+{-# NOINLINE programMtl #-}++catchMtl :: Int -> Either () ()+catchMtl n = M.runExcept $ programMtl n++catchMtlDeep :: Int -> Either () ()+catchMtlDeep n = M.runIdentity $ run $ run $ run $ run $ run $ M.runExceptT $ run $ run $ run $ run $ run $ programMtl n+  where+    run = (`M.runReaderT` ())

@@ -0,0 +1,96 @@+-- SPDX-License-Identifier: BSD-3-Clause+-- (c) 2022 Xy Ren; 2024 Sayo Koyoneda++module BenchCoroutine where++import Control.Monad (forM)+import Control.Monad.Freer qualified as FS+import Control.Monad.Freer.Coroutine qualified as FS+import Control.Monad.Freer.Reader qualified as FS+import Control.Monad.Hefty qualified as H+import Control.Monad.Hefty.Coroutine qualified as H+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]+programFreer upbound =+    forM [1 .. upbound] (`FS.yield` id)+{-# NOINLINE programFreer #-}++loopStatusFreer :: FS.Status es Int Int r -> FS.Eff es r+loopStatusFreer = \case+    FS.Done r -> pure r+    FS.Continue i f -> loopStatusFreer =<< f (i + 100)+{-# NOINLINE loopStatusFreer #-}++coroutineFreer :: Int -> [Int]+coroutineFreer n = FS.run $ loopStatusFreer =<< FS.runC (programFreer n)++coroutineFreerDeep :: Int -> [Int]+coroutineFreerDeep n = FS.run $ run $ run $ run $ run $ run $ loopStatusFreer =<< FS.runC (run $ run $ run $ run $ run $ programFreer n)+  where+    run = FS.runReader ()++programHeftia :: (H.Member (H.Yield Int Int) es) => Int -> H.Eff '[] es [Int]+programHeftia upbound =+    forM [1 .. upbound] H.yield+{-# NOINLINE programHeftia #-}++loopStatusHeftia :: H.Status (H.Eff '[] ef) Int Int r -> H.Eff '[] ef r+loopStatusHeftia = \case+    H.Done r -> pure r+    H.Continue i f -> loopStatusHeftia =<< f (i + 100)+{-# NOINLINE loopStatusHeftia #-}++coroutineHeftia :: Int -> [Int]+coroutineHeftia n = H.runPure $ loopStatusHeftia =<< H.runCoroutine (programHeftia n)++coroutineHeftiaDeep :: Int -> [Int]+coroutineHeftiaDeep n = H.runPure $ run $ run $ run $ run $ run $ loopStatusHeftia =<< H.runCoroutine (run $ run $ run $ run $ run $ programHeftia n)+  where+    run = H.runAsk ()++programEff :: (E.Coroutine Int Int E.:< es) => Int -> E.Eff es [Int]+programEff upbound =+    forM [1 .. upbound] $ E.yield @Int @Int+{-# NOINLINE programEff #-}++loopStatusEff :: E.Status es Int Int r -> E.Eff es r+loopStatusEff = \case+    E.Done r -> pure r+    E.Yielded i f -> loopStatusEff =<< E.runCoroutine (f (i + 100))+{-# NOINLINE loopStatusEff #-}++coroutineEff :: Int -> [Int]+coroutineEff n = E.run $ loopStatusEff =<< E.runCoroutine (programEff n)++coroutineEffDeep :: Int -> [Int]+coroutineEffDeep n = E.run $ run $ run $ run $ run $ run $ loopStatusEff =<< E.runCoroutine (run $ run $ run $ run $ run $ programEff n)+  where+    run = E.runReader ()++programMp :: (MpYield Int Int Mp.:? e) => Int -> Mp.Eff e [Int]+programMp n = forM [0 .. n] $ \i -> Mp.perform mpYield i+{-# NOINLINE programMp #-}++loopStatusMp :: H.Status (Mp.Eff e) Int Int r -> Mp.Eff e r+loopStatusMp = \case+    H.Done r -> pure r+    H.Continue a k -> loopStatusMp =<< k (a + 100)+{-# NOINLINE loopStatusMp #-}++coroutineMp :: Int -> [Int]+coroutineMp n = Mp.runEff $ loopStatusMp =<< mpCoroutine @Int @Int (programMp n)++coroutineMpDeep :: Int -> [Int]+coroutineMpDeep n = Mp.runEff $ run $ run $ run $ run $ run $ loopStatusMp =<< mpCoroutine @Int @Int (run $ run $ run $ run $ run $ programMp n)+  where+    run = Mp.reader ()++newtype MpYield a b e ans = MpYield {mpYield :: Mp.Op a b e ans}++mpCoroutine :: Mp.Eff (MpYield a b Mp.:* e) r -> Mp.Eff e (H.Status (Mp.Eff e) a b r)+mpCoroutine = Mp.handler MpYield {mpYield = Mp.operation $ \a k -> pure $ H.Continue a k} . fmap H.Done

@@ -0,0 +1,186 @@+-- SPDX-License-Identifier: BSD-3-Clause+-- (c) 2022 Xy Ren; 2024 Sayo Koyoneda++-- Benchmarking effect invocation and monadic bind+module BenchCountdown where++import Control.Carrier.Reader qualified as F+import Control.Carrier.State.Strict qualified as F+import Control.Ev.Eff qualified as E+import Control.Ev.Util qualified as E+import Control.Monad.Freer qualified as FS+import Control.Monad.Freer.Reader qualified as FS+import Control.Monad.Freer.State qualified as FS+import Control.Monad.Hefty qualified as H+import Control.Monad.Hefty.Reader qualified as H+import Control.Monad.Hefty.State qualified as H+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+import Polysemy qualified as P+import Polysemy.Reader qualified as P+import Polysemy.State qualified as P+import "eff" Control.Effect qualified as EF++programHeftia :: (H.Member (H.State Int) es) => H.Eff '[] es Int+programHeftia = do+    x <- H.get @Int+    if x == 0+        then pure x+        else do+            H.put (x - 1)+            programHeftia+{-# NOINLINE programHeftia #-}++countdownHeftia :: Int -> (Int, Int)+countdownHeftia n = H.runPure $ H.runState n programHeftia++countdownHeftiaDeep :: Int -> (Int, Int)+countdownHeftiaDeep n = H.runPure $ runR $ runR $ runR $ runR $ runR $ H.runState n $ runR $ runR $ runR $ runR $ runR $ programHeftia+  where+    runR = H.runAsk ()++countdownHeftiaNaive :: Int -> (Int, Int)+countdownHeftiaNaive n = H.runPure $ H.runStateNaive n programHeftia++countdownHeftiaNaiveDeep :: Int -> (Int, Int)+countdownHeftiaNaiveDeep n = H.runPure $ runR $ runR $ runR $ runR $ runR $ H.runStateNaive n $ runR $ runR $ runR $ runR $ runR $ programHeftia+  where+    runR = H.runAsk ()++programFreer :: (FS.Member (FS.State Int) es) => FS.Eff es Int+programFreer = do+    x <- FS.get @Int+    if x == 0+        then pure x+        else do+            FS.put (x - 1)+            programFreer+{-# NOINLINE programFreer #-}++countdownFreer :: Int -> (Int, Int)+countdownFreer n = FS.run $ FS.runState n programFreer++countdownFreerDeep :: Int -> (Int, Int)+countdownFreerDeep n = FS.run $ runR $ runR $ runR $ runR $ runR $ FS.runState n $ runR $ runR $ runR $ runR $ runR $ programFreer+  where+    runR = FS.runReader ()++programSem :: (P.Member (P.State Int) es) => P.Sem es Int+programSem = do+    x <- P.get @Int+    if x == 0+        then pure x+        else do+            P.put (x - 1)+            programSem+{-# NOINLINE programSem #-}++countdownSem :: Int -> (Int, Int)+countdownSem n = P.run $ P.runState n programSem++countdownSemDeep :: Int -> (Int, Int)+countdownSemDeep n = P.run $ runR $ runR $ runR $ runR $ runR $ P.runState n $ runR $ runR $ runR $ runR $ runR $ programSem+  where+    runR = P.runReader ()++programFused :: (F.Has (F.State Int) sig m) => m Int+programFused = do+    x <- F.get @Int+    if x == 0+        then pure x+        else do+            F.put (x - 1)+            programFused+{-# NOINLINE programFused #-}++countdownFused :: Int -> (Int, Int)+countdownFused n = F.run $ F.runState n programFused++countdownFusedDeep :: Int -> (Int, Int)+countdownFusedDeep n = F.run $ runR $ runR $ runR $ runR $ runR $ F.runState n $ runR $ runR $ runR $ runR $ runR $ programFused+  where+    runR = F.runReader ()++programEffectful :: (EL.State Int EL.:> es) => EL.Eff es Int+programEffectful = do+    x <- EL.get @Int+    if x == 0+        then pure x+        else do+            EL.put (x - 1)+            programEffectful+{-# NOINLINE programEffectful #-}++countdownEffectful :: Int -> (Int, Int)+countdownEffectful n = EL.runPureEff $ EL.runStateLocal n programEffectful++countdownEffectfulDeep :: Int -> (Int, Int)+countdownEffectfulDeep n =+    EL.runPureEff $ runR $ runR $ runR $ runR $ runR $ EL.runStateLocal n $ runR $ runR $ runR $ runR $ runR $ programEffectful+  where+    runR = EL.runReader ()++programEff :: (EF.State Int EF.:< es) => EF.Eff es Int+programEff = do+    x <- EF.get @Int+    if x == 0+        then pure x+        else do+            EF.put (x - 1)+            programEff+{-# NOINLINE programEff #-}++countdownEff :: Int -> (Int, Int)+countdownEff n = EF.run $ EF.runState n programEff++countdownEffDeep :: Int -> (Int, Int)+countdownEffDeep n = EF.run $ runR $ runR $ runR $ runR $ runR $ EF.runState n $ runR $ runR $ runR $ runR $ runR $ programEff+  where+    runR = EF.runReader ()++programEv :: (E.State Int E.:? es) => E.Eff es Int+programEv = do+    x <- E.perform (E.get @Int) ()+    if x == 0+        then pure x+        else do+            E.perform E.put (x - 1)+            programEv+{-# NOINLINE programEv #-}++countdownEv :: Int -> (Int, Int)+countdownEv n = E.runEff $ runStateEv n programEv++countdownEvDeep :: Int -> (Int, Int)+countdownEvDeep n = E.runEff $ runR $ runR $ runR $ runR $ runR $ runStateEv n $ runR $ runR $ runR $ runR $ runR $ programEv+  where+    runR = E.reader ()++runStateEv :: s -> E.Eff (E.State s E.:* es) a -> E.Eff es (s, a)+runStateEv s0 m = E.state s0 do+    r <- m+    s <- E.perform E.get ()+    pure (s, r)++programMtl :: (M.MonadState Int m) => m Int+programMtl = do+    x <- M.get @Int+    if x == 0+        then pure x+        else do+            M.put (x - 1)+            programMtl+{-# NOINLINE programMtl #-}++countdownMtl :: Int -> (Int, Int)+countdownMtl = M.runState programMtl++countdownMtlDeep :: Int -> (Int, Int)+countdownMtlDeep n = M.runIdentity $ runR $ runR $ runR $ runR $ runR $ M.runStateT (runR $ runR $ runR $ runR $ runR $ programMtl) n+  where+    runR = (`M.runReaderT` ())

@@ -0,0 +1,152 @@+-- SPDX-License-Identifier: BSD-3-Clause+-- (c) 2022 Xy Ren; 2024 Sayo Koyoneda++-- Benchmarking yield-intensive code+module BenchPyth where++import Control.Algebra qualified as F+import Control.Applicative (Alternative (empty, (<|>)))+import Control.Carrier.NonDet.Church qualified as F+import Control.Carrier.Reader qualified as F+import Control.Ev.Eff qualified as E+import Control.Ev.Util qualified as E+import Control.Monad (MonadPlus)+import Control.Monad.Freer qualified as FS+import Control.Monad.Freer.NonDet qualified as FS+import Control.Monad.Freer.Reader qualified as FS+import Control.Monad.Hefty qualified as H+import Control.Monad.Hefty.NonDet qualified as H+import Control.Monad.Hefty.Reader qualified as H+import Control.Monad.Identity qualified as M+import Control.Monad.Logic qualified as M+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)+programFreer upbound = do+    x <- choice upbound+    y <- choice upbound+    z <- choice upbound+    if x * x + y * y == z * z then return (x, y, z) else empty+  where+    choice 0 = empty+    choice n = choice (n - 1) <|> pure n+{-# NOINLINE programFreer #-}++pythFreer :: Int -> [(Int, Int, Int)]+pythFreer n = FS.run $ FS.makeChoiceA $ programFreer n++pythFreerDeep :: Int -> [(Int, Int, Int)]+pythFreerDeep n = FS.run $ run $ run $ run $ run $ run $ FS.makeChoiceA $ run $ run $ run $ run $ run $ programFreer n+  where+    run = FS.runReader ()++programHeftia :: (H.Member H.Choose es, H.Member H.Empty es) => Int -> H.Eff '[] es (Int, Int, Int)+programHeftia upbound = do+    x <- choice upbound+    y <- choice upbound+    z <- choice upbound+    if x * x + y * y == z * z then return (x, y, z) else H.empty+  where+    choice 0 = H.empty+    choice n = choice (n - 1) `H.branch` pure n+{-# NOINLINE programHeftia #-}++pythHeftia :: Int -> [(Int, Int, Int)]+pythHeftia n = H.runPure $ H.runNonDet $ programHeftia n++pythHeftiaDeep :: Int -> [(Int, Int, Int)]+pythHeftiaDeep n = H.runPure $ run $ run $ run $ run $ run $ H.runNonDet $ run $ run $ run $ run $ run $ programHeftia n+  where+    run = H.runAsk ()++programFused :: (Monad m, Alternative m) => Int -> m (Int, Int, Int)+programFused upbound = do+    x <- choice upbound+    y <- choice upbound+    z <- choice upbound+    if x * x + y * y == z * z then return (x, y, z) else empty+  where+    choice x = F.oneOf [1 .. x]+{-# NOINLINE programFused #-}++pythFused :: Int -> [(Int, Int, Int)]+pythFused n = F.run $ F.runNonDetA $ programFused n++pythFusedDeep :: Int -> [(Int, Int, Int)]+pythFusedDeep n = F.run $ run $ run $ run $ run $ run $ F.runNonDetA $ run $ run $ run $ run $ run $ programFused n+  where+    run = F.runReader ()++programEv :: (E.Choose E.:? e) => Int -> E.Eff e (Int, Int, Int)+programEv upbound = do+    x <- E.perform E.choose upbound+    y <- E.perform E.choose upbound+    z <- E.perform E.choose upbound+    if x * x + y * y == z * z then return (x, y, z) else E.perform (\r -> E.none r) ()+{-# NOINLINE programEv #-}++pythEv :: Int -> [(Int, Int, Int)]+pythEv n = E.runEff $ E.chooseAll $ programEv n++pythEvDeep :: Int -> [(Int, Int, Int)]+pythEvDeep n = E.runEff $ run $ run $ run $ run $ run $ E.chooseAll $ run $ run $ run $ run $ run $ programEv n+  where+    run = E.reader ()++programMp :: (Mp.Choose Mp.:? e) => Int -> Mp.Eff e (Int, Int, Int)+programMp upbound = do+    x <- Mp.perform Mp.choose upbound+    y <- Mp.perform Mp.choose upbound+    z <- Mp.perform Mp.choose upbound+    if x * x + y * y == z * z then return (x, y, z) else Mp.perform (\r -> Mp.none r) ()+{-# NOINLINE programMp #-}++pythMp :: Int -> [(Int, Int, Int)]+pythMp n = Mp.runEff $ Mp.chooseAll $ programMp n++pythMpDeep :: Int -> [(Int, Int, Int)]+pythMpDeep n = Mp.runEff $ run $ run $ run $ run $ run $ Mp.chooseAll $ run $ run $ run $ run $ run $ programMp n+  where+    run = Mp.reader ()++programEff :: (EF.NonDet EF.:< es) => Int -> EF.Eff es (Int, Int, Int)+programEff upbound = do+    x <- choice upbound+    y <- choice upbound+    z <- choice upbound+    if x * x + y * y == z * z then return (x, y, z) else empty+  where+    choice 0 = empty+    choice n = choice (n - 1) <|> pure n+{-# NOINLINE programEff #-}++pythEff :: Int -> [(Int, Int, Int)]+pythEff n = EF.run $ EF.runNonDetAll $ programEff n++pythEffDeep :: Int -> [(Int, Int, Int)]+pythEffDeep n = EF.run $ run $ run $ run $ run $ run $ EF.runNonDetAll $ run $ run $ run $ run $ run $ programEff n+  where+    run = EF.runReader ()++programMtl :: (MonadPlus m) => Int -> m (Int, Int, Int)+programMtl upbound = do+    x <- choice upbound+    y <- choice upbound+    z <- choice upbound+    if x * x + y * y == z * z then return (x, y, z) else empty+  where+    choice 0 = empty+    choice n = choice (n - 1) <|> pure n+{-# NOINLINE programMtl #-}++pythLogict :: Int -> [(Int, Int, Int)]+pythLogict n = M.observeAll $ programMtl n++pythLogictDeep :: Int -> [(Int, Int, Int)]+pythLogictDeep n = M.runIdentity $ runR $ runR $ runR $ runR $ runR $ M.observeAllT $ runR $ runR $ runR $ runR $ runR $ programMtl n+  where+    runR = (`M.runReaderT` ())

@@ -0,0 +1,114 @@+-- SPDX-License-Identifier: BSD-3-Clause+-- (c) 2022 Xy Ren; 2024 Sayo Koyoneda++module Main where++import BenchCatch+import BenchCoroutine+import BenchCountdown+import BenchPyth+import Data.Functor ((<&>))+import Test.Tasty.Bench++main :: IO ()+main =+    defaultMain+        [ bgroup "countdown.shallow" $+            [10000] <&> \x ->+                bgroup+                    (show x)+                    [ bench "heftia" $ nf countdownHeftia x+                    , bench "freer" $ nf countdownFreer x+                    , bench "polyemy" $ nf countdownSem x+                    , bench "fused" $ nf countdownFused x+                    , bench "effectful" $ nf countdownEffectful x+                    , bench "eff" $ nf countdownEff x+                    , bench "ev" $ nf countdownEv x+                    , bench "mtl" $ nf countdownMtl x+                    ]+        , bgroup "countdown.deep" $+            [10000] <&> \x ->+                bgroup+                    (show x)+                    [ bench "heftia.5+5" $ nf countdownHeftiaDeep x+                    , bench "freer.5+5" $ nf countdownFreerDeep x+                    , bench "polysemy.5+5" $ nf countdownSemDeep x+                    , bench "fused.5+5" $ nf countdownFusedDeep x+                    , bench "effectful.5+5" $ nf countdownEffectfulDeep x+                    , bench "eff.5+5" $ nf countdownEffDeep x+                    , bench "ev.5+5" $ nf countdownEvDeep x+                    , bench "mtl.5+5" $ nf countdownMtlDeep x+                    ]+        , bgroup "catch.shallow" $+            [10000] <&> \x ->+                bgroup+                    (show x)+                    [ bench "heftia" $ nf catchHeftia x+                    , bench "polysemy" $ nf catchSem x+                    , bench "fused" $ nf catchFused x+                    , bench "effectful" $ nf catchEffectful x+                    , -- , bench "eff" $ nf catchEff x+                      -- `eff` is x500 slow in this case, so it is excluded because it makes the graph hard to read.+                      bench "mtl" $ nf catchMtl x+                    ]+        , bgroup "catch.deep" $+            [10000] <&> \x ->+                bgroup+                    (show x)+                    [ bench "heftia.5+5+0" $ nf catchHeftiaDeep0 x+                    , bench "heftia.5+4+1" $ nf catchHeftiaDeep1 x+                    , bench "heftia.5+3+2" $ nf catchHeftiaDeep2 x+                    , bench "heftia.5+2+3" $ nf catchHeftiaDeep3 x+                    , bench "heftia.5+1+4" $ nf catchHeftiaDeep4 x+                    , bench "heftia.5+0+5" $ nf catchHeftiaDeep5 x+                    , bench "polysemy.5+5" $ nf catchSemDeep x+                    , bench "fused.5+5" $ nf catchFusedDeep x+                    , bench "effectful.5+5" $ nf catchEffectfulDeep x+                    , -- , bench "eff.5+5" $ nf catchEffDeep x+                      bench "mtl.5+5" $ nf catchMtlDeep x+                    ]+        , bgroup "nondet.shallow" $+            [32] <&> \x ->+                bgroup+                    (show x)+                    [ bench "heftia" $ nf pythHeftia x+                    , bench "freer" $ nf pythFreer x+                    , bench "fused" $ nf pythFused x+                    , bench "ev" $ nf pythEv x+                    , bench "mp" $ nf pythMp x+                    , bench "eff" $ nf pythEff x+                    , bench "mtl-logict" $ nf pythLogict x+                    ] -- Polysemy case is excluded because of incorrect semantics.+        , bgroup "nondet.deep" $+            [32] <&> \x ->+                bgroup+                    (show x)+                    [ bench "heftia.5+5" $ nf pythHeftiaDeep x+                    , bench "freer.5+5" $ nf pythFreerDeep x+                    , bench "fused.5+5" $ nf pythFusedDeep x+                    , bench "ev.5+5" $ nf pythEvDeep x+                    , bench "mp.5+5" $ nf pythMpDeep x+                    , bench "eff.5+5" $ nf pythEffDeep x+                    , bench "mtl-logict.5+5" $ nf pythLogictDeep x+                    ]+        , bgroup "coroutine.shallow" $+            [1000] <&> \x ->+                bgroup+                    (show x)+                    [ bench "heftia" $ nf coroutineHeftia x+                    , bench "freer" $ nf coroutineFreer x+                    , bench "eff" $ nf coroutineEff x+                    , bench "mp" $ nf coroutineMp x+                    -- `mpeff` is O(n^2) slow because of: https://dl.acm.org/doi/10.1145/2633357.2633360+                    -- `eff` is probably for the same reason.+                    ] -- add mtl?+        , bgroup "coroutine.deep" $+            [1000] <&> \x ->+                bgroup+                    (show x)+                    [ bench "heftia.5+5" $ nf coroutineHeftiaDeep x+                    , bench "freer.5+5" $ nf coroutineFreerDeep x+                    , bench "eff.5+5" $ nf coroutineEffDeep x+                    , bench "mp.5+5" $ nf coroutineMpDeep x+                    ]+        ]

@@ -1,6 +1,6 @@ cabal-version:      2.4 name:               heftia-effects-version:            0.3.1.0+version:            0.4.0.0  -- A short (one-line) description of the package. synopsis: higher-order effects done right@@ -16,25 +16,26 @@ -- The license under which the package is released. license:            MPL-2.0 license-file:       LICENSE-author:             Yamada Ryo <ymdfield@outlook.jp>-maintainer:         Yamada Ryo <ymdfield@outlook.jp>+author:             Sayo Koyoneda <ymdfield@outlook.jp>+maintainer:         Sayo Koyoneda <ymdfield@outlook.jp>  -- A copyright notice.-copyright: 2023-2024 Yamada Ryo+copyright: 2023-2024 Sayo Koyoneda category: Control, Effect, Monads -extra-source-files:+extra-doc-files:     ChangeLog.md     NOTICE     README.md  tested-with:-    GHC == 9.2.8+    GHC == 9.8.2+    GHC == 9.4.1  source-repository head     type: git     location: https://github.com/sayo-hs/heftia-    tag: v0.2.0+    tag: v0.4.0     subdir: heftia-effects  common common-base@@ -53,10 +54,14 @@         PatternSynonyms      build-depends:-        base ^>= 4.16,+        base >= 4.17 && < 4.21,+        data-effects ^>= 0.2,+        heftia ^>= 0.4,+        time >= 1.11.1 && < 1.15,+        unliftio ^>= 0.2,+        unbounded-delays ^>= 0.1.1,         ghc-typelits-knownnat ^>= 0.7,-        data-effects ^>= 0.1.2,-        heftia ^>= 0.3.1,+        containers > 0.6.5 && < 0.8,      ghc-options: -Wall -fplugin GHC.TypeLits.KnownNat.Solver @@ -64,42 +69,26 @@     import: common-base      exposed-modules:-        Control.Effect.Interpreter.Heftia.Reader-        Control.Effect.Interpreter.Heftia.Writer-        Control.Effect.Interpreter.Heftia.State-        Control.Effect.Interpreter.Heftia.Except-        Control.Effect.Interpreter.Heftia.ShiftReset-        Control.Effect.Interpreter.Heftia.NonDet-        Control.Effect.Interpreter.Heftia.Coroutine-        Control.Effect.Interpreter.Heftia.Input-        Control.Effect.Interpreter.Heftia.Output-        Control.Effect.Interpreter.Heftia.Provider-        Control.Effect.Interpreter.Heftia.Provider.Implicit-        Control.Effect.Interpreter.Heftia.Resource-        Control.Effect.Interpreter.Heftia.Unlift-        Control.Effect.Interpreter.Heftia.KVStore-        Control.Effect.Interpreter.Heftia.Fresh-        Control.Effect.Interpreter.Heftia.Fail-        Control.Effect.Interpreter.Heftia.Concurrent.Timer+        Control.Monad.Hefty.Reader+        Control.Monad.Hefty.Writer+        Control.Monad.Hefty.State+        Control.Monad.Hefty.Except+        Control.Monad.Hefty.ShiftReset+        Control.Monad.Hefty.NonDet+        Control.Monad.Hefty.Coroutine+        Control.Monad.Hefty.Input+        Control.Monad.Hefty.Output+        Control.Monad.Hefty.Resource+        Control.Monad.Hefty.Unlift+        Control.Monad.Hefty.Provider+        Control.Monad.Hefty.KVStore+        Control.Monad.Hefty.Fresh+        Control.Monad.Hefty.Fail+        Control.Monad.Hefty.Concurrent.Timer      reexported-modules:-        Control.Effect.Hefty,-        Control.Effect.Free,-        Control.Effect.ExtensibleFinal,-        Control.Effect.ExtensibleChurch,-        Control.Effect.ExtensibleTree,-        Control.Effect.ExtensibleFinalA,-        Control.Effect.ExtensibleTreeA,-        Control.Effect.ExtensibleFastA,-        Control.Hefty,-        Control.Freer,-        Control.Freer.Final,-        Control.Monad.Freer,-        Control.Monad.Freer.Church,-        Control.Monad.Freer.Tree,-        Data.Hefty.Union,-        Data.Hefty.Extensible,-        Data.Free.Sum,+        Control.Monad.Hefty,+        Data.Effect.OpenUnion,         Data.Effect,         Data.Effect.TH,         Data.Effect.Tag,@@ -120,10 +109,9 @@         Data.Effect.Coroutine,         Data.Effect.Input,         Data.Effect.Output,-        Data.Effect.Provider,-        Data.Effect.Provider.Implicit,         Data.Effect.Resource,         Data.Effect.Unlift,+        Data.Effect.Provider,         Data.Effect.KVStore,         Data.Effect.Fresh,         Data.Effect.Fail,@@ -135,15 +123,6 @@     -- LANGUAGE extensions used by modules in this package.     -- other-extensions:     build-depends:-        mtl                           ^>= 2.2.2,-        transformers                  ^>= 0.5.6,-        extensible                    ^>= 0.9,-        unliftio                      ^>= 0.2.0,-        free                          ^>= 5.2,-        containers                    ^>= 0.6.5,-        extra                         ^>= 1.7.14,-        time                          ^>= 1.11.1,-        unbounded-delays              ^>= 0.1.1,      hs-source-dirs:   src @@ -152,15 +131,19 @@      main-is: Driver.hs     other-modules:+        Test.Semantics+        Test.Writer+        Test.Pyth+        Test.Coroutine      hs-source-dirs: test      build-depends:         heftia-effects,-        tasty                         ^>= 1.4,-        tasty-hspec,-        hspec,-        unliftio,+        tasty                         >= 1.4 && < 1.6,+        tasty-hspec                   ^>= 1.2,+        hspec                         >= 2.5 && < 2.12,+        unliftio                      ^>= 0.2,      build-tool-depends:         tasty-discover:tasty-discover@@ -192,7 +175,7 @@     build-depends:         heftia-effects,         text >= 2.0 && < 2.2,-        time ^>= 1.11.1,+        time,  executable Continuation     import: common-base@@ -226,3 +209,43 @@     hs-source-dirs: Example/SemanticsZoo     build-depends:         heftia-effects,++executable FileSystemProvider+    import: common-base++    main-is: Main.hs+    hs-source-dirs: Example/FileSystemProvider+    build-depends:+        heftia-effects,++benchmark heftia-bench+    import: common-base++    type:           exitcode-stdio-1.0+    hs-source-dirs: bench+    main-is:        Main.hs++    ghc-options: -fconstraint-solver-iterations=16++    build-depends:+        heftia-effects,+        freer-simple ^>= 1.2,+        polysemy ^>= 1.9,+        fused-effects ^>= 1.1,+        effectful ^>= 2.3,+        eveff ^>= 1.0,+        mtl >= 2.2 && < 2.4,+        logict >= 0.7.0.3 && < 0.9,+        tasty-bench >= 0.3 && < 0.5,+        eff,+        mpeff,++    default-extensions:+        PackageImports++    other-modules:+        BenchCountdown+        BenchCatch+        -- BenchLocal+        BenchCoroutine+        BenchPyth

@@ -1,54 +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 Control.Effect.Interpreter.Heftia.Concurrent.Timer where--import Control.Concurrent.Thread.Delay qualified as Thread-import Control.Effect (sendIns, type (~>))-import Control.Effect.ExtensibleFinal (type (:!!))-import Control.Effect.Hefty (interposeRec, interpret, interpretRec, raise, raiseUnder)-import Control.Effect.Interpreter.Heftia.Coroutine (runCoroutine)-import Control.Effect.Interpreter.Heftia.State (evalState)-import Data.Effect.Concurrent.Timer (CyclicTimer (Wait), LCyclicTimer, LTimer, Timer (..), clock, cyclicTimer)-import Data.Effect.Coroutine (Status (Coroutine, Done))-import Data.Effect.State (get, put)-import Data.Function ((&))-import Data.Hefty.Extensible (ForallHFunctor, type (<|))-import Data.Time (DiffTime)-import Data.Time.Clock (diffTimeToPicoseconds, picosecondsToDiffTime)-import Data.Void (Void, absurd)-import GHC.Clock (getMonotonicTimeNSec)-import UnliftIO (liftIO)--runTimerIO ::-    forall eh ef.-    (IO <| ef, ForallHFunctor eh) =>-    eh :!! LTimer ': ef ~> eh :!! ef-runTimerIO =-    interpretRec \case-        Clock -> do-            t <- getMonotonicTimeNSec & liftIO-            pure $ picosecondsToDiffTime $ fromIntegral t * 1000-        Sleep t ->-            Thread.delay (diffTimeToPicoseconds t `quot` 1000_000) & liftIO--runCyclicTimer :: forall ef. Timer <| ef => '[] :!! LCyclicTimer ': ef ~> '[] :!! ef-runCyclicTimer a = do-    timer0 :: Status ('[] :!! ef) () DiffTime Void <- runCoroutine cyclicTimer-    a & raiseUnder-        & interpret \case-            Wait delta ->-                get @(Status ('[] :!! ef) () DiffTime Void) >>= \case-                    Done x -> absurd x-                    Coroutine () k -> put =<< raise (k delta)-        & evalState timer0--restartClock :: (Timer <| ef, ForallHFunctor eh) => eh :!! ef ~> eh :!! ef-restartClock a = do-    t0 <- clock-    a & interposeRec \case-        Clock -> do-            t <- clock-            pure $ t - t0-        other -> sendIns other

@@ -1,17 +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 Control.Effect.Interpreter.Heftia.Coroutine where--import Control.Effect.Hefty (Eff, interpretK)-import Control.Monad.Freer (MonadFreer)-import Data.Effect.Coroutine (LYield, Status (Coroutine, Done), Yield (Yield))-import Data.Hefty.Union (Union)--runCoroutine ::-    forall a b r er fr u c.-    (MonadFreer c fr, Union u, c (Eff u fr '[] er)) =>-    Eff u fr '[] (LYield a b ': er) r ->-    Eff u fr '[] er (Status (Eff u fr '[] er) a b r)-runCoroutine = interpretK (pure . Done) (\kk (Yield a) -> pure $ Coroutine a kk)

@@ -1,135 +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/.--{- |-Copyright   :  (c) 2023 Yamada Ryo-License     :  MPL-2.0 (see the file LICENSE)-Maintainer  :  ymdfield@outlook.jp-Stability   :  experimental-Portability :  portable--Interpreter and elaborator for the t'Data.Effect.Except.Throw' / t'Data.Effect.Except.Catch' effect-classes.--}-module Control.Effect.Interpreter.Heftia.Except where--import Control.Arrow ((>>>))-import Control.Effect (type (~>))-import Control.Effect.Hefty (-    Eff,-    Elab,-    interposeK,-    interposeT,-    interpretK,-    interpretRec,-    interpretRecH,-    interpretT,- )-import Control.Exception (Exception)-import Control.Monad.Freer (MonadFreer)-import Control.Monad.Trans.Except (ExceptT, runExceptT, throwE)-import Data.Effect.Except (Catch (Catch), LThrow, Throw (Throw))-import Data.Effect.HFunctor (HFunctor)-import Data.Effect.Unlift (UnliftIO)-import Data.Function ((&))-import Data.Hefty.Extensible (ForallHFunctor, type (<<|), type (<|))-import Data.Hefty.Extensible qualified as Ex-import Data.Hefty.Union (Member, Union)-import UnliftIO (throwIO)-import UnliftIO qualified as IO---- | Interpret the "Data.Effect.Except" effects using the 'ExceptT' monad transformer internally.-runExcept ::-    forall e a ef fr u c.-    ( Member u (Throw e) (LThrow e ': ef)-    , MonadFreer c fr-    , Union u-    , c (Eff u fr '[] (LThrow e ': ef))-    , c (ExceptT e (Eff u fr '[] (LThrow e ': ef)))-    , HFunctor (u '[Catch e])-    , c (Eff u fr '[] ef)-    , c (ExceptT e (Eff u fr '[] ef))-    , HFunctor (u '[])-    ) =>-    Eff u fr '[Catch e] (LThrow e ': ef) a ->-    Eff u fr '[] ef (Either e a)-runExcept = runCatch >>> runThrow-{-# INLINE runExcept #-}---- | Elaborate the t'Catch' effect using the 'ExceptT' monad transformer internally.-runCatch ::-    forall e ef fr u c.-    ( Member u (Throw e) ef-    , MonadFreer c fr-    , Union u-    , c (Eff u fr '[] ef)-    , c (ExceptT e (Eff u fr '[] ef))-    , HFunctor (u '[Catch e])-    , HFunctor (u '[])-    ) =>-    Eff u fr '[Catch e] ef ~> Eff u fr '[] ef-runCatch = interpretRecH elabCatch-{-# INLINE runCatch #-}--elabCatch ::-    forall e ef fr u c.-    ( Member u (Throw e) ef-    , MonadFreer c fr-    , Union u-    , c (Eff u fr '[] ef)-    , c (ExceptT e (Eff u fr '[] ef))-    ) =>-    Elab (Catch e) (Eff u fr '[] ef)-elabCatch (Catch action hdl) = do-    r <- runExceptT $ action & interposeT \(Throw e) -> throwE e-    case r of-        Left e -> hdl e-        Right a -> pure a---- | Elaborate the 'Catch' effect using a delimited continuation.-elabCatchK ::-    forall e ef fr u c.-    (Member u (Throw e) ef, MonadFreer c fr, Union u, c (Eff u fr '[] ef)) =>-    Elab (Catch e) (Eff u fr '[] ef)-elabCatchK (Catch action hdl) =-    action & interposeK pure \_ (Throw e) -> hdl e---- | Interpret the 'Throw' effect using the 'ExceptT' monad transformer.-runThrow ::-    forall e r a fr u c.-    (MonadFreer c fr, Union u, c (Eff u fr '[] r), c (ExceptT e (Eff u fr '[] r))) =>-    Eff u fr '[] (LThrow e ': r) a ->-    Eff u fr '[] r (Either e a)-runThrow = runExceptT . runThrowT-{-# INLINE runThrow #-}---- | Interpret the 'Throw' effect using the 'ExceptT' monad transformer.-runThrowT ::-    forall e r fr u c.-    (MonadFreer c fr, Union u, c (Eff u fr '[] r), c (ExceptT e (Eff u fr '[] r))) =>-    Eff u fr '[] (LThrow e ': r) ~> ExceptT e (Eff u fr '[] r)-runThrowT = interpretT \(Throw e) -> throwE e-{-# INLINE runThrowT #-}---- | Interpret the 'Throw' effect using a delimited continuation.-runThrowK ::-    forall e r a fr u c.-    (MonadFreer c fr, Union u, c (Eff u fr '[] r)) =>-    Eff u fr '[] (LThrow e ': r) a ->-    Eff u fr '[] r (Either e a)-runThrowK = interpretK (pure . Right) \_ (Throw e) -> pure $ Left e--runThrowIO ::-    forall e eh ef fr c.-    (MonadFreer c fr, IO <| ef, ForallHFunctor eh, Exception e) =>-    Ex.Eff fr eh (LThrow e ': ef) ~> Ex.Eff fr eh ef-runThrowIO = interpretRec \(Throw e) -> throwIO e-{-# INLINE runThrowIO #-}--runCatchIO ::-    forall e eh ef fr c.-    (MonadFreer c fr, UnliftIO <<| eh, IO <| ef, ForallHFunctor eh, Exception e) =>-    Ex.Eff fr (Catch e ': eh) ef ~> Ex.Eff fr eh ef-runCatchIO = interpretRecH \(Catch action hdl) -> IO.catch action hdl-{-# INLINE runCatchIO #-}

@@ -1,26 +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/.--{- |-Copyright   :  (c) 2024 Yamada Ryo-License     :  MPL-2.0 (see the file LICENSE)-Maintainer  :  ymdfield@outlook.jp-Stability   :  experimental-Portability :  portable--}-module Control.Effect.Interpreter.Heftia.Fail where--import Control.Effect (sendIns, type (~>))-import Control.Effect.Hefty (Eff, interpret)-import Control.Freer (Freer)-import Data.Effect.Fail (Fail (Fail), LFail)-import Data.Effect.HFunctor (HFunctor)-import Data.Hefty.Union (Member, Union)--runFailAsIO ::-    forall r fr u c.-    (Freer c fr, Union u, HFunctor (u '[]), Member u IO r) =>-    Eff u fr '[] (LFail ': r) ~> Eff u fr '[] r-runFailAsIO = interpret \(Fail s) -> sendIns @IO $ fail s-{-# INLINE runFailAsIO #-}

@@ -1,54 +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/.--{- |-Copyright   :  (c) 2024 Yamada Ryo-License     :  MPL-2.0 (see the file LICENSE)-Maintainer  :  ymdfield@outlook.jp-Stability   :  experimental-Portability :  portable--}-module Control.Effect.Interpreter.Heftia.Fresh where--import Control.Arrow ((>>>))-import Control.Effect (type (~>))-import Control.Effect.Hefty (Eff, interpret, raiseUnder)-import Control.Effect.Interpreter.Heftia.State (runState)-import Control.Freer (Freer)-import Control.Monad.State (StateT)-import Data.Effect.Fresh (Fresh (Fresh), LFresh)-import Data.Effect.HFunctor (HFunctor)-import Data.Effect.State (LState, State, get, modify)-import Data.Hefty.Union (Member, Union)-import Numeric.Natural (Natural)--runFreshNatural ::-    ( Freer c fr-    , Union u-    , HFunctor (u '[])-    , Member u (State Natural) (LState Natural ': r)-    , c (Eff u fr '[] r)-    , c (StateT Natural (Eff u fr '[] r))-    , Monad (Eff u fr '[] r)-    , Monad (Eff u fr '[] (LState Natural ': r))-    ) =>-    Eff u fr '[] (LFresh Natural ': r) a ->-    Eff u fr '[] r (Natural, a)-runFreshNatural =-    raiseUnder-        >>> runFreshNaturalAsState-        >>> runState 0-{-# INLINE runFreshNatural #-}--runFreshNaturalAsState ::-    forall r fr u c.-    ( Freer c fr-    , Union u-    , Member u (State Natural) r-    , Monad (Eff u fr '[] r)-    , HFunctor (u '[])-    ) =>-    Eff u fr '[] (LFresh Natural ': r) ~> Eff u fr '[] r-runFreshNaturalAsState =-    interpret \Fresh -> get @Natural <* modify @Natural (+ 1)

@@ -1,62 +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/.--{- |-Copyright   :  (c) 2024 Yamada Ryo-License     :  MPL-2.0 (see the file LICENSE)-Maintainer  :  ymdfield@outlook.jp-Stability   :  experimental-Portability :  portable--}-module Control.Effect.Interpreter.Heftia.Input where--import Control.Arrow ((>>>))-import Control.Effect (type (~>))-import Control.Effect.Hefty (Eff, interpret, interpretRec, raiseUnder)-import Control.Effect.Interpreter.Heftia.State (evalState)-import Control.Freer (Freer)-import Control.Monad.State (StateT)-import Data.Effect.HFunctor (HFunctor)-import Data.Effect.Input (Input (Input), LInput)-import Data.Effect.State (LState, State, gets, put)-import Data.Hefty.Union (Member, Union)-import Data.List (uncons)--runInputEff ::-    forall i r eh fr u c.-    (Freer c fr, Union u, Applicative (Eff u fr eh r), HFunctor (u eh)) =>-    Eff u fr eh r i ->-    Eff u fr eh (LInput i ': r) ~> Eff u fr eh r-runInputEff a = interpretRec \Input -> a-{-# INLINE runInputEff #-}--runInputConst ::-    forall i r eh fr u c.-    (Freer c fr, Union u, Applicative (Eff u fr eh r), HFunctor (u eh)) =>-    i ->-    Eff u fr eh (LInput i ': r) ~> Eff u fr eh r-runInputConst i = interpretRec \Input -> pure i-{-# INLINE runInputConst #-}--runInputList ::-    forall i r fr u c.-    ( Freer c fr-    , Union u-    , Applicative (Eff u fr '[] r)-    , Monad (Eff u fr '[] (LState [i] ': r))-    , c (Eff u fr '[] r)-    , c (StateT [i] (Eff u fr '[] r))-    , Member u (State [i]) (LState [i] ': r)-    , HFunctor (u '[])-    ) =>-    [i] ->-    Eff u fr '[] (LInput (Maybe i) ': r) ~> Eff u fr '[] r-runInputList is =-    raiseUnder-        >>> ( interpret \Input -> do-                is' <- gets @[i] uncons-                mapM_ (put . snd) is'-                pure $ fst <$> is'-            )-        >>> evalState is

@@ -1,65 +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/.--{- |-Copyright   :  (c) 2024 Yamada Ryo-License     :  MPL-2.0 (see the file LICENSE)-Maintainer  :  ymdfield@outlook.jp-Stability   :  experimental-Portability :  portable--This module provides handlers for the t`KVStore` effect, comes-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.Effect.Interpreter.Heftia.KVStore where--import Control.Arrow ((>>>))-import Control.Effect (type (~>))-import Control.Effect.Hefty (Eff, interpret, raiseUnder)-import Control.Effect.Interpreter.Heftia.State (runState)-import Control.Freer (Freer)-import Control.Monad.State (StateT)-import Data.Effect.HFunctor (HFunctor)-import Data.Effect.KVStore (KVStore (LookupKV, UpdateKV), LKVStore)-import Data.Effect.State (LState, State, get, modify)-import Data.Functor ((<&>))-import Data.Hefty.Union (Member, Union)-import Data.Map (Map)-import Data.Map qualified as Map--runKVStorePure ::-    forall k v r a fr u c.-    ( Ord k-    , Freer c fr-    , Union u-    , HFunctor (u '[])-    , Member u (State (Map k v)) (LState (Map k v) ': r)-    , c (Eff u fr '[] r)-    , c (StateT (Map k v) (Eff u fr '[] r))-    , Monad (Eff u fr '[] r)-    , Monad (Eff u fr '[] (LState (Map k v) ': r))-    ) =>-    Map k v ->-    Eff u fr '[] (LKVStore k v ': r) a ->-    Eff u fr '[] r (Map k v, a)-runKVStorePure initial =-    raiseUnder-        >>> runKVStoreAsState-        >>> runState initial-{-# INLINE runKVStorePure #-}--runKVStoreAsState ::-    forall k v r fr u c.-    ( Ord k-    , Freer c fr-    , Union u-    , Member u (State (Map k v)) r-    , Monad (Eff u fr '[] r)-    , HFunctor (u '[])-    ) =>-    Eff u fr '[] (LKVStore k v ': r) ~> Eff u fr '[] r-runKVStoreAsState = interpret \case-    LookupKV k -> get <&> Map.lookup k-    UpdateKV k v -> modify $ Map.update (const v) k

@@ -1,158 +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/.--{- |-Copyright   :  (c) 2024 Yamada Ryo-License     :  MPL-2.0 (see the file LICENSE)-Maintainer  :  ymdfield@outlook.jp-Stability   :  experimental-Portability :  portable--}-module Control.Effect.Interpreter.Heftia.NonDet where--import Control.Applicative (Alternative ((<|>)), empty, liftA2, (<|>))-import Control.Arrow ((>>>))-import Control.Effect (type (~>))-import Control.Effect.Hefty (Eff, injectF, interpretFin, interpretFinH, interpretK, interpretRecH)-import Control.Freer (Freer)-import Control.Monad.Freer (MonadFreer)-import Control.Monad.Trans.Maybe (MaybeT (MaybeT), runMaybeT)-import Data.Bool (bool)-import Data.Effect.HFunctor (HFunctor)-import Data.Effect.NonDet (Choose (Choose), ChooseH (ChooseH), Empty (Empty), LChoose, LEmpty, choose)-import Data.Functor.Compose (Compose (Compose), getCompose)-import Data.Hefty.Union (ForallHFunctor, HFunctorUnion, Member, Union)---- | 'NonDet' effects handler for Monad use.-runNonDet ::-    forall f ef a fr u c.-    ( Alternative f-    , MonadFreer c fr-    , Union u-    , c (Eff u fr '[] ef)-    , c (Eff u fr '[] (LEmpty : ef))-    ) =>-    Eff u fr '[] (LChoose ': LEmpty ': ef) a ->-    Eff u fr '[] ef (f a)-runNonDet =-    runChoose >>> interpretK pure \_ Empty -> pure empty-{-# INLINE runNonDet #-}---- | 'NonDet' effects handler for Monad use.-runNonDetK ::-    forall r ef a fr u c.-    ( Monoid r-    , MonadFreer c fr-    , Union u-    , c (Eff u fr '[] ef)-    , c (Eff u fr '[] (LEmpty ': ef))-    , HFunctor (u '[])-    ) =>-    (a -> Eff u fr '[] (LEmpty ': ef) r) ->-    Eff u fr '[] (LChoose ': LEmpty ': ef) a ->-    Eff u fr '[] ef r-runNonDetK f =-    runChooseK f >>> interpretK pure \_ Empty -> pure mempty-{-# INLINE runNonDetK #-}---- | 'Choose' effect handler for Monad use.-runChoose ::-    forall f ef a fr u c.-    ( Alternative f-    , MonadFreer c fr-    , Union u-    , c (Eff u fr '[] ef)-    ) =>-    Eff u fr '[] (LChoose ': ef) a ->-    Eff u fr '[] ef (f a)-runChoose =-    interpretK (pure . pure) \k Choose ->-        liftA2 (<|>) (k False) (k True)---- | 'Choose' effect handler for Monad use.-runChooseK ::-    forall r ef a fr u c.-    ( Semigroup r-    , MonadFreer c fr-    , Union u-    , c (Eff u fr '[] ef)-    ) =>-    (a -> Eff u fr '[] ef r) ->-    Eff u fr '[] (LChoose ': ef) a ->-    Eff u fr '[] ef r-runChooseK f =-    interpretK f \k Choose ->-        liftA2 (<>) (k False) (k True)---- | 'Empty' effect handler for Monad use.-runEmpty ::-    forall a r fr u c.-    ( Freer c fr-    , Union u-    , Applicative (Eff u fr '[] r)-    , c (MaybeT (Eff u fr '[] r))-    ) =>-    Eff u fr '[] (LEmpty ': r) a ->-    Eff u fr '[] r (Maybe a)-runEmpty =-    runMaybeT . interpretFin-        (MaybeT . fmap Just . injectF)-        \Empty -> MaybeT $ pure Nothing--{- | 'ChooseH' effect handler for Monad use.--    Convert a higher-order effect of the form--        @chooseH :: m a -> m a -> m a@--    into a first-order effect of the form:--        @choose :: m Bool@--}-runChooseH ::-    ( Freer c fr-    , HFunctorUnion u-    , Member u Choose ef-    , ForallHFunctor u eh-    , Monad (Eff u fr eh ef)-    ) =>-    Eff u fr (ChooseH ': eh) ef ~> Eff u fr eh ef-runChooseH =-    interpretRecH \(ChooseH a b) -> do-        world <- choose-        bool a b world---- | 'NonDet' effect handler for Applicative use.-runNonDetA ::-    forall f ef a fr u c.-    ( Alternative f-    , Freer c fr-    , Union u-    , Applicative (Eff u fr '[] ef)-    , c (Compose (Eff u fr '[] ef) f)-    ) =>-    Eff u fr '[ChooseH] (LEmpty ': ef) a ->-    Eff u fr '[] ef (f a)-runNonDetA =-    getCompose-        . interpretFinH-            (Compose . runEmptyA . injectF)-            (\(ChooseH a b) -> Compose $ liftA2 (<|>) (runNonDetA a) (runNonDetA b))---- | 'Empty' effect handler for Applicative use.-runEmptyA ::-    forall f a r fr u c.-    ( Alternative f-    , Freer c fr-    , Union u-    , Applicative (Eff u fr '[] r)-    , c (Compose (Eff u fr '[] r) f)-    ) =>-    Eff u fr '[] (LEmpty ': r) a ->-    Eff u fr '[] r (f a)-runEmptyA =-    getCompose-        . interpretFin-            (Compose . fmap pure . injectF)-            \Empty -> Compose $ pure empty

@@ -1,98 +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/.--{- |-Copyright   :  (c) 2024 Yamada Ryo-License     :  MPL-2.0 (see the file LICENSE)-Maintainer  :  ymdfield@outlook.jp-Stability   :  experimental-Portability :  portable--}-module Control.Effect.Interpreter.Heftia.Output where--import Control.Arrow ((>>>))-import Control.Effect (type (~>))-import Control.Effect.Hefty (Eff, interpret, interpretRec, raiseUnder, send0)-import Control.Effect.Interpreter.Heftia.State (runState)-import Control.Effect.Interpreter.Heftia.Writer (runTell, runTellA)-import Control.Freer (Freer)-import Control.Monad.Trans.State (StateT)-import Control.Monad.Trans.Writer.CPS qualified as CPS-import Control.Monad.Trans.Writer.Strict qualified as Strict-import Data.Effect.HFunctor (HFunctor)-import Data.Effect.Output (LOutput, Output (Output))-import Data.Effect.State (LState, State, modify)-import Data.Effect.Writer (Tell (Tell))-import Data.Hefty.Union (Member, Union)--runOutputEff ::-    (Freer c fr, Union u, HFunctor (u eh)) =>-    (o -> Eff u fr eh r ()) ->-    Eff u fr eh (LOutput o ': r) ~> Eff u fr eh r-runOutputEff f = interpretRec \(Output o) -> f o-{-# INLINE runOutputEff #-}--ignoreOutput ::-    (Freer c fr, Union u, HFunctor (u eh), Applicative (Eff u fr eh r)) =>-    Eff u fr eh (LOutput o ': r) ~> Eff u fr eh r-ignoreOutput = runOutputEff $ const $ pure ()-{-# INLINE ignoreOutput #-}--runOutputList ::-    forall o a r fr u c.-    ( Freer c fr-    , Union u-    , c (Eff u fr '[] r)-    , c (StateT [o] (Eff u fr '[] r))-    , Applicative (Eff u fr '[] r)-    , Monad (Eff u fr '[] (LState [o] ': r))-    , Member u (State [o]) (LState [o] ': r)-    , HFunctor (u '[])-    ) =>-    Eff u fr '[] (LOutput o ': r) a ->-    Eff u fr '[] r ([o], a)-runOutputList =-    raiseUnder-        >>> interpret (\(Output o) -> modify (o :))-        >>> runState []--{- | Run an `Output` effect by transforming into a monoid.-     The carrier is required to be a monad.--}-runOutputMonoid ::-    forall o m a r fr u c.-    ( Monoid m-    , Freer c fr-    , Union u-    , Monad (Eff u fr '[] r)-    , c (CPS.WriterT m (Eff u fr '[] r))-    , HFunctor (u '[])-    ) =>-    (o -> m) ->-    Eff u fr '[] (LOutput o ': r) a ->-    Eff u fr '[] r (m, a)-runOutputMonoid f =-    raiseUnder-        >>> interpret (\(Output o) -> send0 $ Tell $ f o)-        >>> runTell--{- | Strict version of `runOutputMonoid`.-     The constraint on the carrier has been weakened to applicative.--}-runOutputMonoidA ::-    forall o m a r fr u c.-    ( Monoid m-    , Freer c fr-    , Union u-    , Applicative (Eff u fr '[] r)-    , c (Strict.WriterT m (Eff u fr '[] r))-    , HFunctor (u '[])-    ) =>-    (o -> m) ->-    Eff u fr '[] (LOutput o ': r) a ->-    Eff u fr '[] r (m, a)-runOutputMonoidA f =-    raiseUnder-        >>> interpret (\(Output o) -> send0 $ Tell $ f o)-        >>> runTellA

@@ -1,39 +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/.--{- |-Copyright   :  (c) 2023 Yamada Ryo-License     :  MPL-2.0 (see the file LICENSE)-Maintainer  :  ymdfield@outlook.jp-Stability   :  experimental-Portability :  portable--Elaborator for the t'Control.Effect.Class.Provider.Provider' effect class.--}-module Control.Effect.Interpreter.Heftia.Provider where--import Control.Effect (type (~>))-import Control.Effect.Hefty (Elab)-import Control.Monad.Trans (MonadTrans, lift)-import Data.Effect.Provider (Provider' (Provide))---- | Elaborate the t'Control.Effect.Class.Provider.Provider' effect using the given interpreter.-runProvider ::-    (c g, e g) =>-    (f ~> g) ->-    (i -> forall x. g x -> f (ctx x)) ->-    Elab (Provider' c i ctx e) f-runProvider iLower run (Provide i f) = run i $ f iLower-{-# INLINE runProvider #-}--{- |-Elaborate the t'Control.Effect.Class.Provider.Provider' effect using the given interpreter for some-monad transformer.--}-runProviderT ::-    (Monad m, MonadTrans t, c (t m), e (t m)) =>-    (i -> forall x. t m x -> m (ctx x)) ->-    Elab (Provider' c i ctx e) m-runProviderT = runProvider lift-{-# INLINE runProviderT #-}

@@ -1,44 +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/.--{- |-Copyright   :  (c) 2023 Yamada Ryo-License     :  MPL-2.0 (see the file LICENSE)-Maintainer  :  ymdfield@outlook.jp-Stability   :  experimental-Portability :  portable--Elaborator for the t'Control.Effect.Class.Provider.Implicit.ImplicitProvider' effect class.--}-module Control.Effect.Interpreter.Heftia.Provider.Implicit where--import Control.Effect (type (~>))-import Control.Effect.Hefty (Eff, Elab, raise)-import Control.Effect.Interpreter.Heftia.Reader (runAsk)-import Control.Freer (Freer)-import Data.Effect.HFunctor (HFunctor)-import Data.Effect.Provider.Implicit (ImplicitProvider' (WithImplicit))-import Data.Effect.Reader (LAsk)-import Data.Hefty.Union (Union)---- | Elaborate the t'ImplicitProvider'' effect using the given interpreter.-elaborateImplicitProvider ::-    (c g, e g) =>-    (f ~> g) ->-    (i -> forall x. g x -> f x) ->-    Elab (ImplicitProvider' c i e) f-elaborateImplicitProvider iLower run (WithImplicit i f) = run i $ f iLower-{-# INLINE elaborateImplicitProvider #-}--runImplicitProvider ::-    ( e (Eff u fr eh (LAsk i ': ef))-    , c (Eff u fr eh (LAsk i ': ef))-    , Freer c fr-    , Union u-    , HFunctor (u eh)-    , Applicative (Eff u fr eh ef)-    ) =>-    Elab (ImplicitProvider' c i e) (Eff u fr eh ef)-runImplicitProvider (WithImplicit i f) = runAsk i $ f raise-{-# INLINE runImplicitProvider #-}

@@ -1,72 +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/.--{- |-Copyright   :  (c) 2023 Yamada Ryo-License     :  MPL-2.0 (see the file LICENSE)-Maintainer  :  ymdfield@outlook.jp-Stability   :  experimental-Portability :  portable--Interpreter and elaborator for the t'Data.Effect.Reader.Local' / t'Data.Effect.Reader.Catch' effect-classes.--}-module Control.Effect.Interpreter.Heftia.Reader where--import Control.Arrow ((>>>))-import Control.Effect (type (~>))-import Control.Effect.Hefty (-    Eff,-    Elab,-    interposeRec,-    interpretRec,-    interpretRecH,- )-import Control.Freer (Freer)-import Data.Effect.HFunctor (HFunctor)-import Data.Effect.Reader (Ask (..), LAsk, Local (..), ask)-import Data.Function ((&))-import Data.Hefty.Union (ForallHFunctor, HFunctorUnion, Member, Union)--runReader ::-    forall r rh rf fr u c.-    ( Freer c fr-    , HFunctorUnion u-    , ForallHFunctor u rh-    , Member u (Ask r) (LAsk r ': rf)-    , Functor (Eff u fr rh (LAsk r ': rf))-    , Applicative (Eff u fr rh rf)-    ) =>-    r ->-    Eff u fr (Local r ': rh) (LAsk r ': rf) ~> Eff u fr rh rf-runReader r = runLocal >>> runAsk r-{-# INLINE runReader #-}---- | Elaborate the t'Local' effect.-runLocal ::-    forall r rh ef fr u c.-    ( Freer c fr-    , HFunctorUnion u-    , ForallHFunctor u rh-    , Member u (Ask r) ef-    , Functor (Eff u fr rh ef)-    ) =>-    Eff u fr (Local r ': rh) ef ~> Eff u fr rh ef-runLocal = interpretRecH elabLocal-{-# INLINE runLocal #-}--elabLocal ::-    forall r eh ef fr u c.-    (Member u (Ask r) ef, Freer c fr, Union u, HFunctor (u eh), Functor (Eff u fr eh ef)) =>-    Elab (Local r) (Eff u fr eh ef)-elabLocal (Local f a) = a & interposeRec @(Ask r) \Ask -> f <$> ask---- | Interpret the t'Ask' effect.-runAsk ::-    forall r rs eh fr u c.-    (Freer c fr, Union u, Applicative (Eff u fr eh rs), HFunctor (u eh)) =>-    r ->-    Eff u fr eh (LAsk r ': rs) ~> Eff u fr eh rs-runAsk r = interpretRec \Ask -> pure r-{-# INLINE runAsk #-}

@@ -1,26 +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/.--{- |-Copyright   :  (c) 2023 Yamada Ryo-               (c) 2017 FP Complete-               (c) 2022 Fumiaki Kinoshita-License     :  MPL-2.0 (see the file LICENSE)-Maintainer  :  ymdfield@outlook.jp-Stability   :  experimental-Portability :  portable--An elaborator for the t'Control.Effect.Class.Resource.Resource' effect class.--}-module Control.Effect.Interpreter.Heftia.Resource where--import Control.Effect.Hefty (Elab)-import Data.Effect.Resource (Resource (Bracket, BracketOnExcept))-import UnliftIO (MonadUnliftIO, bracket, bracketOnError)---- | Elaborates the `Resource` effect under the `MonadUnliftIO` context.-resourceToIO :: MonadUnliftIO m => Elab Resource m-resourceToIO = \case-    Bracket acquire release thing -> bracket acquire release thing-    BracketOnExcept acquire onError thing -> bracketOnError acquire onError thing

@@ -1,70 +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 Control.Effect.Interpreter.Heftia.ShiftReset where--import Control.Arrow ((>>>))-import Control.Effect (type (~>))-import Control.Effect.Hefty (-    Eff,-    injectH,-    interpretKAllH,-    interpretKH,-    interpretRecH,-    raiseH,-    runEff,- )-import Control.Freer (Freer)-import Control.Monad ((<=<))-import Control.Monad.Freer (MonadFreer)-import Data.Effect (LiftIns)-import Data.Effect.HFunctor (HFunctor, hfmap)-import Data.Effect.Key (KeyH (KeyH))-import Data.Effect.ShiftReset (Reset (Reset), Shift, Shift' (Shift), Shift_ (Shift_))-import Data.Hefty.Union (HFunctorUnion, HFunctorUnion_ (ForallHFunctor), Union ((|+:)))--evalShift ::-    (MonadFreer c fr, Union u, c (Eff u fr '[] ef), HFunctor (u '[])) =>-    Eff u fr '[Shift r] ef r ->-    Eff u fr '[] ef r-evalShift = runShift pure-{-# INLINE evalShift #-}--runShift ::-    forall r a ef fr u c.-    (MonadFreer c fr, Union u, c (Eff u fr '[] ef), HFunctor (u '[])) =>-    (a -> Eff u fr '[] ef r) ->-    Eff u fr '[Shift r] ef a ->-    Eff u fr '[] ef r-runShift f =-    interpretKH f \k ->-        let k' = raiseH . k-         in evalShift . \case-                KeyH (Shift g) -> g k'--withShift ::-    ( MonadFreer c fr-    , Union u-    , c (Eff u fr '[] '[LiftIns (Eff u fr eh ef)])-    , c (Eff u fr eh ef)-    , HFunctor (u '[])-    ) =>-    Eff u fr '[Shift r] '[LiftIns (Eff u fr eh ef)] r ->-    Eff u fr eh ef r-withShift = evalShift >>> runEff-{-# INLINE withShift #-}--runShift_ ::-    (MonadFreer c fr, Union u, c (Eff u fr eh ef), HFunctor (u eh)) =>-    Eff u fr (Shift_ ': eh) ef ~> Eff u fr eh ef-runShift_ =-    interpretKAllH pure \k ->-        (\(Shift_ f) -> runShift_ $ f $ raiseH . k)-            |+: (k <=< injectH . hfmap runShift_)--runReset ::-    (Freer c fr, HFunctorUnion u, ForallHFunctor u eh) =>-    Eff u fr (Reset ': eh) ef ~> Eff u fr eh ef-runReset = interpretRecH \(Reset a) -> a-{-# INLINE runReset #-}

@@ -1,120 +0,0 @@-{-# LANGUAGE AllowAmbiguousTypes #-}---- This Source Code Form is subject to the terms of the Mozilla Public--- License, v. 2.0. If a copy of the MPL was not distributed with this--- file, You can obtain one at https://mozilla.org/MPL/2.0/.--{- |-Copyright   :  (c) 2023 Yamada Ryo-License     :  MPL-2.0 (see the file LICENSE)-Maintainer  :  ymdfield@outlook.jp-Stability   :  experimental-Portability :  portable--Interpreter for the t'Control.Effect.Class.State.State' effect class.--}-module Control.Effect.Interpreter.Heftia.State where--import Control.Arrow ((>>>))-import Control.Effect (type (~>))-import Control.Effect.Hefty (Eff, injectF, interpose, interposeT, interpret, interpretFin, interpretK, raiseUnder)-import Control.Effect.Interpreter.Heftia.Reader (runAsk)-import Control.Freer (Freer)-import Control.Monad.Freer (MonadFreer)-import Control.Monad.State (StateT)-import Control.Monad.Trans.State qualified as T-import Data.Effect.HFunctor (HFunctor)-import Data.Effect.Reader (Ask (Ask), LAsk, ask)-import Data.Effect.State (LState, State (Get, Put), get, put)-import Data.Function ((&))-import Data.Functor ((<&>))-import Data.Hefty.Union (Member, Union)-import Data.Tuple (swap)-import UnliftIO (MonadIO, newIORef, readIORef, writeIORef)---- | Interpret the 'Get'/'Put' effects using the 'StateT' monad transformer.-runState ::-    forall s r a fr u c.-    (Freer c fr, Union u, c (Eff u fr '[] r), c (StateT s (Eff u fr '[] r)), Applicative (Eff u fr '[] r)) =>-    s ->-    Eff u fr '[] (LState s ': r) a ->-    Eff u fr '[] r (s, a)-runState s a = swap <$> T.runStateT (runStateT a) s-{-# INLINE runState #-}--evalState ::-    forall s r fr u c.-    (Freer c fr, Union u, c (Eff u fr '[] r), c (StateT s (Eff u fr '[] r)), Applicative (Eff u fr '[] r)) =>-    s ->-    Eff u fr '[] (LState s ': r) ~> Eff u fr '[] r-evalState s a = snd <$> runState s a-{-# INLINE evalState #-}--execState ::-    forall s r a fr u c.-    (Freer c fr, Union u, c (Eff u fr '[] r), c (StateT s (Eff u fr '[] r)), Applicative (Eff u fr '[] r)) =>-    s ->-    Eff u fr '[] (LState s ': r) a ->-    Eff u fr '[] r s-execState s a = fst <$> runState s a-{-# INLINE execState #-}---- | Interpret the 'Get'/'Put' effects using the 'StateT' monad transformer.-runStateT ::-    forall s r fr u c.-    (Freer c fr, Union u, c (StateT s (Eff u fr '[] r)), c (Eff u fr '[] r), Applicative (Eff u fr '[] r)) =>-    Eff u fr '[] (LState s ': r) ~> StateT s (Eff u fr '[] r)-runStateT =-    interpretFin (\u -> T.StateT \s -> (,s) <$> injectF u) fuseStateEffect---- | Interpret the 'Get'/'Put' effects using delimited continuations.-runStateK ::-    forall s r a fr u c.-    ( MonadFreer c fr-    , Union u-    , HFunctor (u '[])-    , Member u (Ask s) (LAsk s ': r)-    , c (Eff u fr '[] (LAsk s ': r))-    , Applicative (Eff u fr '[] r)-    ) =>-    s ->-    Eff u fr '[] (LState s ': r) a ->-    Eff u fr '[] r (s, a)-runStateK initialState =-    raiseUnder-        >>> interpretK-            (\a -> ask <&> (,a))-            ( \k -> \case-                Get -> k =<< ask-                Put s -> k () & interpose @(Ask s) \Ask -> pure s-            )-        >>> runAsk initialState--runStateIORef ::-    forall s r a fr u c.-    (Freer c fr, Union u, MonadIO (Eff u fr '[] r)) =>-    s ->-    Eff u fr '[] (LState s ': r) a ->-    Eff u fr '[] r (s, a)-runStateIORef s m = do-    ref <- newIORef s-    a <--        m & interpret \case-            Get -> readIORef ref-            Put s' -> writeIORef ref s'-    readIORef ref <&> (,a)--transactState ::-    forall s r fr u c.-    (Freer c fr, Union u, Member u (State s) r, Monad (Eff u fr '[] r), c (StateT s (Eff u fr '[] r))) =>-    Eff u fr '[] r ~> Eff u fr '[] r-transactState m = do-    pre <- get @s-    (a, post) <- T.runStateT (interposeT fuseStateEffect m) pre-    put post-    pure a--fuseStateEffect :: Applicative f => State s ~> StateT s f-fuseStateEffect = \case-    Get -> T.StateT \s -> pure (s, s)-    Put s -> T.StateT \_ -> pure ((), s)

@@ -1,34 +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/.--{- |-Copyright   :  (c) 2024 Yamada Ryo-License     :  MPL-2.0 (see the file LICENSE)-Maintainer  :  ymdfield@outlook.jp-Stability   :  experimental-Portability :  portable--}-module Control.Effect.Interpreter.Heftia.Unlift where--import Control.Effect (type (~>))-import Control.Effect.Hefty (Eff, interpretH, runEff, send0)-import Control.Freer (Freer)-import Data.Effect (LiftIns)-import Data.Effect.Unlift (UnliftBase (WithRunInBase), UnliftIO)-import Data.Hefty.Union (Union)--runUnliftBase ::-    forall b fr u c.-    (Freer c fr, Union u, c b) =>-    Eff u fr '[UnliftBase b] '[LiftIns b] ~> b-runUnliftBase =-    runEff . interpretH \(WithRunInBase f) ->-        send0 $ f runUnliftBase--runUnliftIO ::-    forall fr u c.-    (Freer c fr, Union u, c IO) =>-    Eff u fr '[UnliftIO] '[LiftIns IO] ~> IO-runUnliftIO = runUnliftBase-{-# INLINE runUnliftIO #-}

@@ -1,319 +0,0 @@-{-# LANGUAGE AllowAmbiguousTypes #-}---- This Source Code Form is subject to the terms of the Mozilla Public--- License, v. 2.0. If a copy of the MPL was not distributed with this--- file, You can obtain one at https://mozilla.org/MPL/2.0/.--{- |-Copyright   :  (c) 2023 Yamada Ryo-License     :  MPL-2.0 (see the file LICENSE)-Maintainer  :  ymdfield@outlook.jp-Stability   :  experimental-Portability :  portable--Interpreter and elaborator for the t'Control.Effect.Class.Writer.Writer' effect class.-See [README.md](https://github.com/sayo-hs/heftia/blob/master/README.md).--}-module Control.Effect.Interpreter.Heftia.Writer where--import Control.Arrow ((>>>))-import Control.Effect (type (~>))-import Control.Effect.Hefty (-    Eff,-    Elab,-    injectF,-    interposeFin,-    interposeT,-    interpretFin,-    interpretK,-    interpretRecH,-    interpretT,-    rewrite,- )-import Control.Freer (Freer)-import Control.Monad.Freer (MonadFreer)-import Control.Monad.Trans (lift)-import Control.Monad.Trans.Writer.CPS qualified as CPS-import Control.Monad.Trans.Writer.Strict qualified as Strict-import Data.Effect.HFunctor (HFunctor)-import Data.Effect.Writer (LTell, Tell (Tell), WriterH (Censor, Listen), tell)-import Data.Function ((&))-import Data.Hefty.Union (Member, Union)-import Data.Tuple (swap)---- | 'Writer' effect handler with post-applying censor semantics for Monad use.-runWriterPost ::-    forall w a r fr u c.-    ( Monoid w-    , Freer c fr-    , Union u-    , HFunctor (u '[])-    , Monad (Eff u fr '[] r)-    , c (CPS.WriterT w (Eff u fr '[] r))-    , Member u (Tell w) (LTell w ': r)-    , Monad (Eff u fr '[] (LTell w ': r))-    , c (CPS.WriterT w (Eff u fr '[] (LTell w ': r)))-    , HFunctor (u '[WriterH w])-    ) =>-    Eff u fr '[WriterH w] (LTell w ': r) a ->-    Eff u fr '[] r (w, a)-runWriterPost = elaborateWriterPost >>> runTell-{-# INLINE runWriterPost #-}--elaborateWriterPost ::-    forall w ef fr u c.-    ( Monoid w-    , Freer c fr-    , Union u-    , Member u (Tell w) ef-    , HFunctor (u '[])-    , Monad (Eff u fr '[] ef)-    , c (CPS.WriterT w (Eff u fr '[] ef))-    , HFunctor (u '[WriterH w])-    ) =>-    Eff u fr '[WriterH w] ef ~> Eff u fr '[] ef-elaborateWriterPost = interpretRecH elabWriterPost-{-# INLINE elaborateWriterPost #-}--elabWriterPost ::-    forall w ef fr u c.-    ( Monoid w-    , Freer c fr-    , Union u-    , Member u (Tell w) ef-    , HFunctor (u '[])-    , Monad (Eff u fr '[] ef)-    , c (CPS.WriterT w (Eff u fr '[] ef))-    ) =>-    Elab (WriterH w) (Eff u fr '[] ef)-elabWriterPost = \case-    Listen m -> listenT m-    Censor f m -> postCensor f m--postCensor ::-    forall w es fr u c.-    ( Monoid w-    , Freer c fr-    , Member u (Tell w) es-    , Union u-    , HFunctor (u '[])-    , Monad (Eff u fr '[] es)-    , c (CPS.WriterT w (Eff u fr '[] es))-    ) =>-    (w -> w) ->-    Eff u fr '[] es ~> Eff u fr '[] es-postCensor f m = do-    (a, w) <- CPS.runWriterT $ confiscateT m-    tell $ f w-    pure a---- | 'Writer' effect handler with pre-applying censor semantics for Monad use.-runWriterPre ::-    forall w a r fr u c.-    ( Monoid w-    , Freer c fr-    , Union u-    , HFunctor (u '[])-    , Monad (Eff u fr '[] r)-    , c (CPS.WriterT w (Eff u fr '[] r))-    , Member u (Tell w) (LTell w ': r)-    , Monad (Eff u fr '[] (LTell w ': r))-    , c (CPS.WriterT w (Eff u fr '[] (LTell w ': r)))-    , HFunctor (u '[WriterH w])-    ) =>-    Eff u fr '[WriterH w] (LTell w ': r) a ->-    Eff u fr '[] r (w, a)-runWriterPre = elaborateWriterPre >>> runTell-{-# INLINE runWriterPre #-}--elaborateWriterPre ::-    forall w ef fr u c.-    ( Monoid w-    , Freer c fr-    , Union u-    , Member u (Tell w) ef-    , HFunctor (u '[])-    , Monad (Eff u fr '[] ef)-    , c (CPS.WriterT w (Eff u fr '[] ef))-    , HFunctor (u '[WriterH w])-    ) =>-    Eff u fr '[WriterH w] ef ~> Eff u fr '[] ef-elaborateWriterPre = interpretRecH elabWriterPre-{-# INLINE elaborateWriterPre #-}--elabWriterPre ::-    forall w ef fr u c.-    ( Monoid w-    , Freer c fr-    , Union u-    , Member u (Tell w) ef-    , HFunctor (u '[])-    , Monad (Eff u fr '[] ef)-    , c (CPS.WriterT w (Eff u fr '[] ef))-    ) =>-    Elab (WriterH w) (Eff u fr '[] ef)-elabWriterPre = \case-    Listen m -> listenT m-    Censor f m -> preCensor f m---- | 'Writer' effect handler with pre-applying censor semantics for Applicative use.-runWriterPreA ::-    forall w a r fr u c.-    ( Monoid w-    , Freer c fr-    , Union u-    , HFunctor (u '[])-    , Monad (Eff u fr '[] r)-    , c (Strict.WriterT w (Eff u fr '[] r))-    , Member u (Tell w) (LTell w ': r)-    , Monad (Eff u fr '[] (LTell w ': r))-    , c (Strict.WriterT w (Eff u fr '[] (LTell w ': r)))-    , HFunctor (u '[WriterH w])-    ) =>-    Eff u fr '[WriterH w] (LTell w ': r) a ->-    Eff u fr '[] r (w, a)-runWriterPreA = elaborateWriterPreA >>> runTellA-{-# INLINE runWriterPreA #-}--elaborateWriterPreA ::-    forall w ef fr u c.-    ( Monoid w-    , Freer c fr-    , Union u-    , Member u (Tell w) ef-    , HFunctor (u '[])-    , Applicative (Eff u fr '[] ef)-    , c (Strict.WriterT w (Eff u fr '[] ef))-    , HFunctor (u '[WriterH w])-    ) =>-    Eff u fr '[WriterH w] ef ~> Eff u fr '[] ef-elaborateWriterPreA = interpretRecH elabWriterPre'-{-# INLINE elaborateWriterPreA #-}--elabWriterPre' ::-    forall w ef fr u c.-    ( Monoid w-    , Freer c fr-    , Union u-    , Member u (Tell w) ef-    , HFunctor (u '[])-    , Applicative (Eff u fr '[] ef)-    , c (Strict.WriterT w (Eff u fr '[] ef))-    ) =>-    Elab (WriterH w) (Eff u fr '[] ef)-elabWriterPre' = \case-    Listen m -> listenTA m-    Censor f m -> preCensor f m--preCensor ::-    forall w es fr u c.-    (Freer c fr, Member u (Tell w) es, Union u, HFunctor (u '[])) =>-    (w -> w) ->-    Eff u fr '[] es ~> Eff u fr '[] es-preCensor f = rewrite @(Tell w) \(Tell w) -> Tell $ f w--listenT ::-    forall w es a fr u c.-    ( Monoid w-    , Freer c fr-    , Union u-    , Member u (Tell w) es-    , Monad (Eff u fr '[] es)-    , c (CPS.WriterT w (Eff u fr '[] es))-    ) =>-    Eff u fr '[] es a ->-    Eff u fr '[] es (w, a)-listenT m =-    swap <$> CPS.runWriterT do-        m & interposeT @(Tell w) \(Tell w) -> do-            lift $ tell w-            CPS.tell w--listenTA ::-    forall w es a fr u c.-    ( Monoid w-    , Freer c fr-    , Union u-    , Member u (Tell w) es-    , Applicative (Eff u fr '[] es)-    , c (Strict.WriterT w (Eff u fr '[] es))-    ) =>-    Eff u fr '[] es a ->-    Eff u fr '[] es (w, a)-listenTA m =-    swap <$> Strict.runWriterT do-        m & interposeFin @(Tell w) (liftStrictWriterT . injectF) \(Tell w) -> do-            liftStrictWriterT (tell w) *> tellStrictWriterT w--runTell ::-    (Monoid w, Freer c fr, Union u, Monad (Eff u fr '[] r), c (CPS.WriterT w (Eff u fr '[] r))) =>-    Eff u fr '[] (LTell w ': r) a ->-    Eff u fr '[] r (w, a)-runTell = fmap swap . CPS.runWriterT . runTellT-{-# INLINE runTell #-}--runTellT ::-    (Monoid w, Freer c fr, Union u, Monad (Eff u fr '[] r), c (CPS.WriterT w (Eff u fr '[] r))) =>-    Eff u fr '[] (LTell w ': r) ~> CPS.WriterT w (Eff u fr '[] r)-runTellT = interpretT \(Tell w) -> CPS.tell w-{-# INLINE runTellT #-}--runTellA ::-    (Monoid w, Freer c fr, Union u, Applicative (Eff u fr '[] r), c (Strict.WriterT w (Eff u fr '[] r))) =>-    Eff u fr '[] (LTell w ': r) a ->-    Eff u fr '[] r (w, a)-runTellA = fmap swap . Strict.runWriterT . runTellTA-{-# INLINE runTellA #-}--runTellTA ::-    (Monoid w, Freer c fr, Union u, Applicative (Eff u fr '[] r), c (Strict.WriterT w (Eff u fr '[] r))) =>-    Eff u fr '[] (LTell w ': r) ~> Strict.WriterT w (Eff u fr '[] r)-runTellTA = interpretFin (liftStrictWriterT . injectF) \(Tell w) -> tellStrictWriterT w-{-# INLINE runTellTA #-}--runTellK ::-    (Monoid w, MonadFreer c fr, Union u, c (Eff u fr '[] r)) =>-    Eff u fr '[] (LTell w ': r) a ->-    Eff u fr '[] r (w, a)-runTellK =-    interpretK (pure . (mempty,)) \k (Tell w) -> do-        (w', r) <- k ()-        pure (w <> w', r)--liftStrictWriterT :: forall w f. (Monoid w, Functor f) => f ~> Strict.WriterT w f-liftStrictWriterT = Strict.WriterT . ((,mempty) <$>)-{-# INLINE liftStrictWriterT #-}--tellStrictWriterT :: forall w f. Applicative f => w -> Strict.WriterT w f ()-tellStrictWriterT = Strict.WriterT . pure . ((),)-{-# INLINE tellStrictWriterT #-}--transactWriter ::-    forall w es a fr u c.-    ( Monoid w-    , Freer c fr-    , Union u-    , Member u (Tell w) es-    , Monad (Eff u fr '[] es)-    , c (CPS.WriterT w (Eff u fr '[] es))-    ) =>-    Eff u fr '[] es a ->-    Eff u fr '[] es a-transactWriter m = do-    (a, w) <- CPS.runWriterT $ confiscateT m-    tell @w w-    pure a--confiscateT ::-    forall w es a fr u c.-    ( Monoid w-    , Freer c fr-    , Union u-    , Member u (Tell w) es-    , Monad (Eff u fr '[] es)-    , c (CPS.WriterT w (Eff u fr '[] es))-    ) =>-    Eff u fr '[] es a ->-    CPS.WriterT w (Eff u fr '[] es) a-confiscateT m =-    m & interposeT @(Tell w) \(Tell w) -> CPS.tell w

@@ -0,0 +1,62 @@+-- SPDX-License-Identifier: MPL-2.0++module Control.Monad.Hefty.Concurrent.Timer where++import Control.Concurrent.Thread.Delay qualified as Thread+import Control.Monad.Hefty.Coroutine (runCoroutine)+import Control.Monad.Hefty.State (evalState)+import Control.Monad.Hefty (+    interpose,+    interpret,+    liftIO,+    raise,+    raiseUnder,+    send,+    (&),+    type (:!!),+    type (<|),+    type (~>),+ )+import Data.Effect.Concurrent.Timer (CyclicTimer (Wait), Timer (..), clock, cyclicTimer)+import Data.Effect.Coroutine (Status (Continue, Done))+import Data.Effect.State (get, put)+import Data.Time (DiffTime)+import Data.Time.Clock (diffTimeToPicoseconds, picosecondsToDiffTime)+import Data.Void (Void, absurd)+import GHC.Clock (getMonotonicTimeNSec)++runTimerIO+    :: forall eh ef+     . (IO <| ef)+    => eh :!! Timer ': ef ~> eh :!! ef+runTimerIO =+    interpret \case+        Clock -> do+            t <- getMonotonicTimeNSec & liftIO+            pure $ picosecondsToDiffTime $ fromIntegral t * 1000+        Sleep t ->+            Thread.delay (diffTimeToPicoseconds t `quot` 1000_000) & liftIO++runCyclicTimer+    :: forall ef+     . (Timer <| ef)+    => '[] :!! CyclicTimer ': ef ~> '[] :!! ef+runCyclicTimer a = do+    timer0 :: Status ('[] :!! ef) () DiffTime Void <- runCoroutine cyclicTimer+    a+        & raiseUnder+        & interpret \case+            Wait delta ->+                get @(Status ('[] :!! ef) () DiffTime Void) >>= \case+                    Done x -> absurd x+                    Continue () k -> put =<< raise (k delta)+        & evalState timer0++restartClock :: (Timer <| ef) => eh :!! ef ~> eh :!! ef+restartClock a = do+    t0 <- clock+    a & interpose \case+        Clock -> do+            t <- clock+            pure $ t - t0+        other -> send other

@@ -0,0 +1,13 @@+-- SPDX-License-Identifier: MPL-2.0++module Control.Monad.Hefty.Coroutine where++import Control.Monad.Hefty.Interpret (interpretBy)+import Control.Monad.Hefty.Types (Eff)+import Data.Effect.Coroutine (Status (Continue, Done), Yield (Yield))++runCoroutine+    :: forall a b ans r+     . Eff '[] (Yield a b ': r) ans+    -> Eff '[] r (Status (Eff '[] r) a b ans)+runCoroutine = interpretBy (pure . Done) (\(Yield a) k -> pure $ Continue a k)

@@ -0,0 +1,70 @@+-- 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/.++{- |+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.+-}+module Control.Monad.Hefty.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.Unlift (UnliftIO)+import UnliftIO (throwIO)+import UnliftIO qualified as IO++runExcept :: Eff '[Catch e] (Throw e ': r) a -> Eff '[] r (Either e a)+runExcept = runThrow . runCatch++runThrow :: Eff '[] (Throw e ': r) a -> Eff '[] r (Either e a)+runThrow = interpretBy (pure . Right) handleThrow++runCatch :: (Throw e <| ef) => Eff '[Catch e] ef ~> Eff '[] ef+runCatch = interpretH elabCatch++handleThrow :: Interpreter (Throw e) (Eff '[] r) (Either e a)+handleThrow (Throw e) _ = pure $ Left e+{-# INLINE handleThrow #-}++elabCatch :: (Throw e <| ef) => Catch e ~~> Eff '[] ef+elabCatch (Catch action hdl) = action & interposeWith \(Throw e) _ -> hdl e+{-# INLINE elabCatch #-}++runThrowIO+    :: forall e eh ef+     . (IO <| ef, Exception e)+    => Eff eh (Throw e ': ef) ~> Eff eh ef+runThrowIO = interpret \(Throw e) -> throwIO e++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

@@ -0,0 +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/.++{- |+Copyright   :  (c) 2024 Sayo Koyoneda+License     :  MPL-2.0 (see the LICENSE file)+Maintainer  :  ymdfield@outlook.jp+Portability :  portable+-}+module Control.Monad.Hefty.Fail where++import Control.Monad.Hefty (Eff, interpret, liftIO, type (<|), type (~>))+import Data.Effect.Fail (Fail (Fail))++runFailIO :: (IO <| ef) => Eff eh (Fail ': ef) ~> Eff eh ef+runFailIO = interpret \(Fail s) -> liftIO $ fail s

@@ -0,0 +1,28 @@+-- 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/.++{- |+Copyright   :  (c) 2024 Sayo Koyoneda+License     :  MPL-2.0 (see the LICENSE file)+Maintainer  :  ymdfield@outlook.jp+Portability :  portable+-}+module Control.Monad.Hefty.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.State (State, get, modify)+import Numeric.Natural (Natural)++runFreshNatural :: Eff '[] (Fresh Natural ': r) a -> Eff '[] r (Natural, a)+runFreshNatural =+    raiseUnder >>> runFreshNaturalAsState >>> runState 0++runFreshNaturalAsState+    :: (State Natural <| r)+    => Eff eh (Fresh Natural ': r) ~> Eff eh r+runFreshNaturalAsState =+    interpret \Fresh -> get @Natural <* modify @Natural (+ 1)

@@ -0,0 +1,41 @@+-- 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/.++{- |+Copyright   :  (c) 2024 Sayo Koyoneda+License     :  MPL-2.0 (see the LICENSE file)+Maintainer  :  ymdfield@outlook.jp+Portability :  portable+-}+module Control.Monad.Hefty.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.State (gets, put)+import Data.List (uncons)++runInputEff+    :: forall i ef eh+     . Eff eh ef i+    -> Eff eh (Input i ': ef) ~> Eff eh ef+runInputEff a = interpret \Input -> a++runInputConst+    :: forall i ef eh+     . i+    -> Eff eh (Input i ': ef) ~> Eff eh ef+runInputConst i = interpret \Input -> pure i++runInputList :: forall i r. [i] -> Eff '[] (Input (Maybe i) ': r) ~> Eff '[] r+runInputList is =+    raiseUnder+        >>> int+        >>> evalState is+  where+    int = interpret \Input -> do+        is' <- gets @[i] uncons+        mapM_ (put . snd) is'+        pure $ fst <$> is'

@@ -0,0 +1,43 @@+-- 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/.++{- |+Copyright   :  (c) 2024 Sayo Koyoneda+License     :  MPL-2.0 (see the LICENSE file)+Maintainer  :  ymdfield@outlook.jp+Portability :  portable++This module provides handlers for the t`KVStore` effect, comes+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++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.State (State, get, modify)+import Data.Functor ((<&>))+import Data.Map (Map)+import Data.Map qualified as Map++runKVStorePure+    :: forall k v r a+     . (Ord k)+    => Map k v+    -> Eff '[] (KVStore k v ': r) a+    -> Eff '[] r (Map k v, a)+runKVStorePure initial =+    raiseUnder+        >>> runKVStoreAsState+        >>> runState initial++runKVStoreAsState+    :: forall k v r+     . (Ord k, State (Map k v) <| r)+    => Eff '[] (KVStore k v ': r) ~> Eff '[] r+runKVStoreAsState = interpret \case+    LookupKV k -> get <&> Map.lookup k+    UpdateKV k v -> modify $ Map.update (const v) k

@@ -0,0 +1,112 @@+{-# LANGUAGE CPP #-}++-- 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/.++{- |+Copyright   :  (c) 2024 Sayo Koyoneda+License     :  MPL-2.0 (see the LICENSE file)+Maintainer  :  ymdfield@outlook.jp+Portability :  portable+-}+module Control.Monad.Hefty.NonDet where++import Control.Applicative (Alternative ((<|>)), empty, (<|>))+#if ( __GLASGOW_HASKELL__ < 906 )+import Control.Applicative (liftA2)+#endif+import Control.Arrow ((>>>))+import Control.Monad.Hefty (+    Eff,+    bundleN,+    interpretBy,+    interpretH,+    nil,+    (!+),+    type (<|),+    type (~>),+ )+import Data.Bool (bool)+import Data.Effect.NonDet (Choose (Choose), ChooseH (ChooseH), Empty (Empty), choose)++-- | 'NonDet' effects handler for alternative answer type.+runNonDet+    :: forall f ef a+     . (Alternative f)+    => Eff '[] (Choose ': Empty ': ef) a+    -> Eff '[] ef (f a)+runNonDet =+    bundleN @2+        >>> interpretBy+            (pure . pure)+            ( (\Choose k -> liftA2 (<|>) (k False) (k True))+                !+ (\Empty _ -> pure empty)+                !+ nil+            )++-- | 'NonDet' effects handler for monoidal answer type.+runNonDetMonoid+    :: forall ans ef a+     . (Monoid ans)+    => (a -> Eff '[] ef ans)+    -> Eff '[] (Choose ': Empty ': ef) a+    -> Eff '[] ef ans+runNonDetMonoid f =+    bundleN @2+        >>> interpretBy+            f+            ( (\Choose k -> liftA2 (<>) (k False) (k True))+                !+ (\Empty _ -> pure mempty)+                !+ nil+            )++-- | 'Choose' effect handler for alternative answer type.+runChoose+    :: forall f ef a+     . (Alternative f)+    => Eff '[] (Choose ': ef) a+    -> Eff '[] ef (f a)+runChoose =+    interpretBy (pure . pure) \Choose k ->+        liftA2 (<|>) (k False) (k True)++-- | 'Choose' effect handler for monoidal answer type.+runChooseMonoid+    :: forall ans ef a+     . (Semigroup ans)+    => (a -> Eff '[] ef ans)+    -> Eff '[] (Choose ': ef) a+    -> Eff '[] ef ans+runChooseMonoid f =+    interpretBy f \Choose k ->+        liftA2 (<>) (k False) (k True)++-- | 'Empty' effect handler.+runEmpty :: forall a r. Eff '[] (Empty ': r) a -> Eff '[] r (Maybe a)+runEmpty =+    interpretBy+        (pure . Just)+        \Empty _ -> pure Nothing++{- | 'ChooseH' effect elaborator.++    Convert a higher-order effect of the form++        @chooseH :: m a -> m a -> m a@++    into a first-order effect of the form:++        @choose :: m Bool@+-}+runChooseH+    :: (Choose <| ef)+    => Eff (ChooseH ': eh) ef ~> Eff eh ef+runChooseH = interpretH \(ChooseH a b) -> branch a b++-- | Faster than `<|>`.+branch :: (Choose <| ef) => Eff eh ef a -> Eff eh ef a -> Eff eh ef a+branch a b = do+    world <- choose+    bool a b world+{-# INLINE branch #-}

@@ -0,0 +1,51 @@+-- 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/.++{- |+Copyright   :  (c) 2024 Sayo Koyoneda+License     :  MPL-2.0 (see the LICENSE file)+Maintainer  :  ymdfield@outlook.jp+Portability :  portable+-}+module Control.Monad.Hefty.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.State (modify)+import Data.Effect.Writer (Tell (Tell))++runOutputEff+    :: forall o ef eh+     . (o -> Eff eh ef ())+    -> Eff eh (Output o ': ef) ~> Eff eh ef+runOutputEff f = interpret \(Output o) -> f o++ignoreOutput+    :: forall o ef eh+     . Eff eh (Output o ': ef) ~> Eff eh ef+ignoreOutput = runOutputEff $ const $ pure ()++runOutputList+    :: forall o a ef+     . Eff '[] (Output o ': ef) a+    -> Eff '[] ef ([o], a)+runOutputList =+    raiseUnder+        >>> interpret (\(Output o) -> modify (o :))+        >>> runState []++-- | Run an `Output` effect by transforming into a monoid.+runOutputMonoid+    :: forall o w a ef+     . ( Monoid w+       )+    => (o -> w)+    -> Eff '[] (Output o ': ef) a+    -> Eff '[] ef (w, a)+runOutputMonoid f =+    interpretStateBy mempty (curry pure) \(Output o) ->+        handleTell $ Tell $ f o

@@ -0,0 +1,97 @@+{-# 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+-}+module Control.Monad.Hefty.Provider where++import Control.Monad.Hefty (+    Eff,+    HFunctor,+    MemberHBy,+    interpretH,+    raise,+    raiseNH,+    tag,+    tagH,+    untag,+    untagH,+    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.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)++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)++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)+       )+    -> 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)++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+       )+    -> Eff (ProviderFix_ i eh rh ef rf ': rh) rf ~> Eff rh rf+runProvider_ run = runProvider \i m -> run i $ Identity <$> m++provide+    :: forall tag ctx i eh ef a sh bh sf bf+     . ( MemberHBy+            (ProviderKey ctx i)+            (Provider' ctx i (ProviderBase ctx i sh bh sf bf))+            eh+       , HFunctor sh+       )+    => 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+       )+    -> Eff eh ef (ctx a)+provide i f =+    i P...! \runInBase ->+        ProviderBase . untag . untagH $ f $ tagH . tag . unProviderBase . runInBase++provide_+    :: forall tag i eh ef a sh bh sf bf+     . ( MemberHBy+            (ProviderKey Identity i)+            (Provider' Identity i (ProviderBase Identity i sh bh sf 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 a+provide_ i f =+    i P..! \runInBase ->+        ProviderBase . untag . untagH $ f $ tagH . tag . unProviderBase . runInBase

@@ -0,0 +1,51 @@+-- 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/.++{- |+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.+-}+module Control.Monad.Hefty.Reader where++import Control.Monad.Hefty (+    Eff,+    interpose,+    interpret,+    interpretH,+    (&),+    type (<|),+    type (~>),+    type (~~>),+ )+import Data.Effect.Reader (Ask (..), Local (..), ask)++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.+runLocal+    :: forall r eh ef+     . (Ask r <| ef)+    => Eff (Local r ': eh) ef ~> Eff eh ef+runLocal = interpretH elabLocal++elabLocal+    :: forall r eh ef+     . (Ask r <| ef)+    => Local r ~~> Eff eh ef+elabLocal (Local f a) = a & interpose @(Ask r) \Ask -> f <$> ask++-- | Interpret the t'Ask' effect.+runAsk+    :: forall r ef eh+     . r+    -> Eff eh (Ask r ': ef) ~> Eff eh ef+runAsk r = interpret \Ask -> pure r

@@ -0,0 +1,36 @@+-- 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/.++{- |+Copyright   :  (c) 2023 Sayo Koyoneda+               (c) 2017 FP Complete+               (c) 2022 Fumiaki Kinoshita+License     :  MPL-2.0 (see the LICENSE file)+Maintainer  :  ymdfield@outlook.jp+Portability :  portable++An elaborator for the t'Control.Effect.Class.Resource.Resource' effect class.+-}+module Control.Monad.Hefty.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.Unlift (UnliftIO)+import UnliftIO (MonadUnliftIO, bracket, bracketOnError)++-- | Elaborates the `Resource` effect under the `UnliftIO` context.+runResourceIO+    :: (UnliftIO <<| eh, IO <| ef)+    => Eff (Resource ': eh) ef ~> Eff eh ef+runResourceIO = interpretH elabResourceIO++elabResourceIO :: (MonadUnliftIO m) => Resource ~~> m+elabResourceIO = \case+    Bracket acquire release thing -> bracket acquire release thing+    BracketOnExcept acquire onError thing -> bracketOnError acquire onError thing+{-# INLINE elabResourceIO #-}

@@ -0,0 +1,47 @@+-- 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 Control.Monad.Hefty.ShiftReset where++import Control.Monad.Hefty (+    Eff,+    interpretH,+    interpretHBy,+    interpretRecHWith,+    raiseH,+    runEff,+    type (~>),+ )+import Data.Effect.Key (KeyH (KeyH))+import Data.Effect.ShiftReset (+    Reset (Reset),+    Shift,+    Shift' (Shift),+    Shift_,+    Shift_' (Shift_'),+ )++type ShiftFix ans eh ef = Shift ans (ShiftBase ans eh ef)++newtype ShiftBase ans eh ef a+    = ShiftBase {unShiftBase :: Eff (Shift ans (ShiftBase ans eh ef) ': eh) ef a}+    deriving newtype (Functor, Applicative, Monad)++evalShift :: Eff '[ShiftFix 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 f =+    interpretHBy f \e k ->+        evalShift $ case e of+            KeyH (Shift g) -> unShiftBase $ g (ShiftBase . raiseH . k) ShiftBase++withShift :: Eff '[ShiftFix 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++runReset :: forall r ef. Eff (Reset ': r) ef ~> Eff r ef+runReset = interpretH \(Reset a) -> a

@@ -0,0 +1,93 @@+{-# LANGUAGE AllowAmbiguousTypes #-}++-- 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 for the t'Data.Effect.State.State' effect.+-}+module Control.Monad.Hefty.State where++import Control.Arrow ((>>>))+import Control.Monad.Hefty (+    Eff,+    StateInterpreter,+    interpose,+    interposeStateBy,+    interpret,+    interpretBy,+    interpretRecWith,+    interpretStateBy,+    interpretStateRecWith,+    raiseUnder,+    (&),+    type (<|),+    type (~>),+ )+import Control.Monad.Hefty.Reader (runAsk)+import Data.Effect.Reader (Ask (Ask), ask)+import Data.Effect.State (State (Get, Put), get, put)+import Data.Functor ((<&>))+import UnliftIO (newIORef, readIORef, writeIORef)++-- | Interpret the 'Get'/'Put' effects.+runState :: forall s ef a. s -> Eff '[] (State s ': ef) a -> Eff '[] ef (s, a)+runState s0 = interpretStateBy s0 (curry pure) handleState++evalState :: forall s ef a. s -> Eff '[] (State s ': ef) a -> Eff '[] ef a+evalState s0 = interpretStateBy s0 (const pure) handleState++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++handleState :: StateInterpreter s (State s) (Eff eh r) ans+handleState = \case+    Put s -> \_ k -> k s ()+    Get -> \s k -> k s s+{-# INLINE handleState #-}++runStateIORef+    :: forall s ef eh a+     . (IO <| ef)+    => s+    -> Eff eh (State s ': ef) a+    -> Eff eh ef (s, a)+runStateIORef s0 m = do+    ref <- newIORef s0+    a <-+        m & interpret \case+            Get -> readIORef ref+            Put s -> writeIORef ref s+    readIORef ref <&> (,a)++transactState :: forall s ef. (State s <| ef) => Eff '[] ef ~> Eff '[] ef+transactState m = do+    pre <- get @s+    (post, a) <- interposeStateBy pre (curry pure) handleState m+    put post+    pure a++-- | A naive but somewhat slower version of 'runState' that does not use ad-hoc optimizations.+runStateNaive :: forall s ef a. s -> Eff '[] (State s ': ef) a -> Eff '[] ef (s, a)+runStateNaive s0 m = do+    f <-+        m & interpretBy (\a -> pure \s -> pure (s, a)) \case+            Get -> \k -> pure \s -> k s >>= ($ s)+            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 =+    raiseUnder+        >>> interpretRecWith \case+            Get -> (ask @s >>=)+            Put s -> \k -> k () & interpose @(Ask s) \Ask -> pure s+        >>> runAsk @s s0

@@ -0,0 +1,23 @@+-- 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/.++{- |+Copyright   :  (c) 2024 Sayo Koyoneda+License     :  MPL-2.0 (see the LICENSE file)+Maintainer  :  ymdfield@outlook.jp+Portability :  portable+-}+module Control.Monad.Hefty.Unlift where++import Control.Monad.Hefty (Eff, interpretH, runEff, send0, type (~>))+import Data.Effect.Unlift (UnliftBase (WithRunInBase), UnliftIO)++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 #-}

@@ -0,0 +1,97 @@+{-# 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/.++{- |+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).+-}+module Control.Monad.Hefty.Writer where++import Control.Monad.Hefty (+    Eff,+    StateInterpreter,+    interpose,+    interposeStateBy,+    interpretH,+    interpretStateBy,+    send,+    type (<|),+    type (~>),+ )+import Data.Effect.Writer (Tell (Tell), WriterH (Censor, Listen), tell)++-- | 'Writer' effect handler 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.+runWriterPre :: (Monoid w) => Eff '[WriterH w] (Tell w ': ef) a -> Eff '[] ef (w, a)+runWriterPre = runTell . runWriterHPre++runTell :: (Monoid w) => Eff '[] (Tell w ': ef) a -> Eff '[] ef (w, a)+runTell = interpretStateBy mempty (curry pure) handleTell++handleTell :: (Monoid w) => StateInterpreter w (Tell w) (Eff '[] ef) (w, a)+handleTell (Tell w') w k = k (w <> w') ()+{-# INLINE handleTell #-}++runWriterHPost :: (Monoid w, Tell w <| ef) => Eff '[WriterH w] ef ~> Eff '[] ef+runWriterHPost = interpretH \case+    Listen m -> listen m+    Censor f m -> censorPost f m++runWriterHPre :: (Monoid w, Tell w <| ef) => Eff '[WriterH w] ef ~> Eff '[] ef+runWriterHPre = interpretH \case+    Listen m -> listen 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+    :: forall w ef a+     . (Tell w <| ef, Monoid w)+    => Eff '[] ef a+    -> Eff '[] ef (w, a)+listen =+    interposeStateBy @_ @(Tell w)+        mempty+        (curry pure)+        \e@(Tell _) w k -> do+            () <- send e+            handleTell e w k++{- | Consumes all the v'tell' effects from the specified @Tell w@ slot within the+given action and returns the accumulated monoidal value along with the result.+-}+confiscate+    :: forall w ef a+     . (Tell w <| ef, Monoid w)+    => Eff '[] ef a+    -> Eff '[] ef (w, a)+confiscate = interposeStateBy mempty (curry pure) handleTell++censorPost+    :: forall w ef+     . (Tell w <| ef, Monoid w)+    => (w -> w)+    -> Eff '[] ef ~> Eff '[] ef+censorPost f m = do+    (w, a) <- confiscate m+    tell $ f w+    pure a++censorPre+    :: forall w eh ef+     . (Tell w <| ef, Monoid w)+    => (w -> w)+    -> Eff eh ef ~> Eff eh ef+censorPre f = interpose @(Tell w) \(Tell w) -> tell $ f w

@@ -1,5 +1,3 @@ {-# OPTIONS_GHC -F -pgmF tasty-discover #-} --- 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

@@ -0,0 +1,24 @@+-- SPDX-License-Identifier: MPL-2.0++module Test.Coroutine where++import Control.Monad (forM)+import Control.Monad.Hefty.Coroutine (runCoroutine)+import Control.Monad.Hefty.Interpret (runPure)+import Control.Monad.Hefty.Types (Eff)+import Data.Effect.Coroutine (Status (..), Yield, yield)+import Data.Effect.OpenUnion.Internal.FO (type (<|))+import Test.Hspec (Spec, it, shouldBe)++generateSeq :: (Yield Int Int <| ef) => Int -> Eff '[] ef [Int]+generateSeq n =+    forM [1 .. n] yield++replyDouble :: Status (Eff '[] ef) Int Int r -> Eff '[] ef r+replyDouble = \case+    Done r -> pure r+    Continue i f -> replyDouble =<< f (i * 2)++spec_Coroutine :: Spec+spec_Coroutine = it "Generator & Reply" do+    runPure (replyDouble =<< runCoroutine (generateSeq 5)) `shouldBe` [2, 4, 6, 8, 10]

@@ -0,0 +1,33 @@+-- SPDX-License-Identifier: MPL-2.0++module Test.Pyth where++import Control.Applicative (empty, (<|>))+import Control.Monad (MonadPlus)+import Control.Monad.Hefty.Interpret (runPure)+import Control.Monad.Hefty.NonDet (runChooseH, runNonDet)+import Test.Hspec (Spec, describe, it, shouldBe)++search :: (MonadPlus m) => Int -> m (Int, Int, Int)+search upbound = do+    x <- choice upbound+    y <- choice upbound+    z <- choice upbound+    if x * x + y * y == z * z then return (x, y, z) else empty+  where+    choice 0 = empty+    choice n = choice (n - 1) <|> pure n++spec_Pyth :: Spec+spec_Pyth = describe "Non-Deterministic Search for Pythagorean triangle numbers" do+    it "n = 16" do+        (runPure . runNonDet . runChooseH $ search 16)+            `shouldBe` [ (3, 4, 5)+                       , (4, 3, 5)+                       , (5, 12, 13)+                       , (6, 8, 10)+                       , (8, 6, 10)+                       , (9, 12, 15)+                       , (12, 5, 13)+                       , (12, 9, 15)+                       ]

@@ -0,0 +1,89 @@+{-# LANGUAGE AllowAmbiguousTypes #-}+{-# LANGUAGE TemplateHaskell #-}++-- SPDX-License-Identifier: MPL-2.0++module Test.Semantics where++import Control.Applicative ((<|>))+import Control.Effect (type (~>))+import Control.Monad.Hefty (+    interpret,+    runPure,+    type ($),+    type (:!!),+    type (<<|),+    type (<|),+ )+import Control.Monad.Hefty.Except (runCatch, runThrow)+import Control.Monad.Hefty.NonDet (runChooseH, runNonDet)+import Control.Monad.Hefty.State (evalState)+import Control.Monad.Hefty.Writer (runTell, runWriterHPre)+import Data.Effect.Except (Catch, Throw, catch, throw)+import Data.Effect.NonDet (ChooseH, Empty)+import Data.Effect.State (State, get, put)+import Data.Effect.TH (makeEffectF)+import Data.Effect.Writer (Tell, WriterH, listen, tell)+import Data.Functor (($>))+import Data.Monoid (Sum (Sum))+import Test.Hspec (Spec, describe, it, shouldBe)++spec_State_Except :: Spec+spec_State_Except = describe "State & Except semantics" do+    let action :: (State Bool <| ef, Throw () <| ef, Catch () <<| eh) => (eh :!! ef) Bool+        action = do+            (put True *> throw ()) `catch` \() -> pure ()+            get++    it "evalState . runThrow  $ (put True *> throw) `catch` ()  ==>  Right True" do+        runPure (evalState False . runThrow @() . runCatch @() $ action) `shouldBe` Right True+    it "runThrow  . evalState $ (put True *> throw) `catch` ()  ==>  Right True" do+        runPure (runThrow @() . evalState False . runCatch @() $ action) `shouldBe` Right True++spec_NonDet_Except :: Spec+spec_NonDet_Except = describe "NonDet & Except semantics" do+    let action1+            , action2+                :: (Empty <| ef, ChooseH <<| eh, Throw () <| ef, Catch () <<| eh) => eh :!! ef $ Bool+        action1 = (pure True <|> throw ()) `catch` \() -> pure False+        action2 = (throw () <|> pure True) `catch` \() -> pure False++    it "runNonDet . runThrow  $ (True <|> throw) `catch` False  ==>  [Right True, Right False]" do+        runPure (runNonDet @[] . runThrow @() . runCatch @() . runChooseH $ action1) `shouldBe` [Right True, Right False]+    it "runThrow  . runNonDet $ (True <|> throw) `catch` False  ==>  Right [True, False]" do+        runPure (runThrow @() . runNonDet @[] . runCatch @() . runChooseH $ action1) `shouldBe` Right [True, False]+    it "runNonDet . runThrow  $ (throw <|> True) `catch` False  ==>  [Right False, Right False]" do+        runPure (runNonDet @[] . runThrow @() . runCatch @() . runChooseH $ action2) `shouldBe` [Right False, Right True]+    it "runThrow  . runNonDet $ (throw <|> True) `catch` False  ==>  Right [False, True]" do+        runPure (runThrow @() . runNonDet @[] . runCatch @() . runChooseH $ action2) `shouldBe` Right [False, True]++spec_NonDet_Writer :: Spec+spec_NonDet_Writer = describe "NonDet & Writer semantics" do+    let action+            :: (Empty <| ef, ChooseH <<| eh, Tell (Sum Int) <| ef, WriterH (Sum Int) <<| eh)+            => eh :!! ef $ (Sum Int, Bool)+        action = listen $ add 1 *> (add 2 $> True <|> add 3 $> False)+          where+            add = tell . Sum @Int++    it "runNonDet . runTell   $ listen $ add 1 *> (add 2 $> True <|> add 3 $> False)  ==>  [(3, (3, True)), (4, (4, False))]" do+        runPure (runNonDet @[] . runTell @(Sum Int) . runWriterHPre @(Sum Int) . runChooseH $ action) `shouldBe` [(3, (3, True)), (4, (4, False))]+    it "runTell   . runNonDet $ listen $ add 1 *> (add 2 $> True <|> add 3 $> False)  ==>  (6, [(3, True), (4, False)])" do+        runPure (runTell @(Sum Int) . runNonDet @[] . runWriterHPre @(Sum Int) . runChooseH $ action) `shouldBe` (6, [(3, True), (4, False)])++data SomeEff a where+    SomeAction :: SomeEff String+makeEffectF [''SomeEff]++spec_The_issue_12 :: Spec+spec_The_issue_12 = describe "hasura/eff#12 semantics" do+    let action :: (Catch String <<| eh, Throw String <| ef, SomeEff <| ef) => eh :!! ef $ String+        action = someAction `catch` \(_ :: String) -> pure "caught"++        runSomeEff :: (Throw String <| ef) => eh :!! SomeEff ': ef ~> eh :!! ef+        runSomeEff = interpret (\SomeAction -> throw "not caught")++    it "runCatch . interpret (\\SomeAction -> throw \"not caught\") $ someAction `catch` \"caught\"  ==>  Right \"caught\"" do+        runPure (runThrow @String . runCatch @String . runSomeEff $ action) `shouldBe` Right "caught"+    it "interpret (\\SomeAction -> throw \"not caught\") . runCatch $ someAction `catch` \"caught\"  ==>  Left \"not caught\"" do+        runPure (runThrow @String . runSomeEff . runCatch @String $ action) `shouldBe` Left "not caught"

@@ -0,0 +1,36 @@+-- SPDX-License-Identifier: MPL-2.0++module Test.Writer where++import Control.Effect (type (<:), type (<<:))+import Control.Monad.Hefty.Interpret (runEff)+import Control.Monad.Hefty.Writer (runTell, runWriterHPost, runWriterHPre)+import Data.Effect.Writer (Tell, WriterH, censor, tell)+import Test.Hspec (Spec, describe, it, shouldBe)++hello :: (Tell String <: m, Monad m) => m ()+hello = do+    tell "Hello"+    tell " world!"++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++spec_Writer_Elaboration :: Spec+spec_Writer_Elaboration = describe "Elaboration for Writer" do+    it "Pre-applying Cencor" do+        (sPre, ()) <- runEff . runTell . runWriterHPre @String $ censorHello+        sPre `shouldBe` "Goodbye world!"+    it "Post-applying Cencor" do+        (sPre, ()) <- runEff . runTell . runWriterHPost @String $ censorHello+        sPre `shouldBe` "Hello world!!"