heftia-effects 0.2.0.0 → 0.3.0.0

raw patch · 41 files changed

+1685/−1477 lines, 41 filesdep +hspecdep +tasty-hspecdep +unbounded-delaysdep −logleveldep −tasty-hunitdep ~data-effectsdep ~heftiadep ~unliftioPVP ok

version bump matches the API change (PVP)

Dependencies added: hspec, tasty-hspec, unbounded-delays

Dependencies removed: loglevel, tasty-hunit

Dependency ranges changed: data-effects, heftia, unliftio

API changes (from Hackage documentation)

Files

• ChangeLog.md +7/−0
• Example/Continuation/Main.hs +4/−4
• Example/Continuation2/Main.hs +3/−3
• Example/Logging/Main.hs +170/−87
• Example/SemanticsZoo/Main.hs +4/−4
• Example/Writer/Main.hs +1/−1
• README.md +73/−38
• heftia-effects.cabal +30/−22
• src/Control/Effect/Handler/Heftia/Coroutine.hs +0/−17
• src/Control/Effect/Handler/Heftia/Except.hs +0/−114
• src/Control/Effect/Handler/Heftia/Fail.hs +0/−26
• src/Control/Effect/Handler/Heftia/Fresh.hs +0/−54
• src/Control/Effect/Handler/Heftia/Input.hs +0/−62
• src/Control/Effect/Handler/Heftia/KVStore.hs +0/−65
• src/Control/Effect/Handler/Heftia/NonDet.hs +0/−158
• src/Control/Effect/Handler/Heftia/Output.hs +0/−98
• src/Control/Effect/Handler/Heftia/Provider.hs +0/−39
• src/Control/Effect/Handler/Heftia/Provider/Implicit.hs +0/−44
• src/Control/Effect/Handler/Heftia/Reader.hs +0/−72
• src/Control/Effect/Handler/Heftia/Resource.hs +0/−26
• src/Control/Effect/Handler/Heftia/ShiftReset.hs +0/−70
• src/Control/Effect/Handler/Heftia/State.hs +0/−120
• src/Control/Effect/Handler/Heftia/Unlift.hs +0/−34
• src/Control/Effect/Handler/Heftia/Writer.hs +0/−319
• src/Control/Effect/Interpreter/Heftia/Concurrent/Timer.hs +54/−0
• src/Control/Effect/Interpreter/Heftia/Coroutine.hs +17/−0
• src/Control/Effect/Interpreter/Heftia/Except.hs +135/−0
• src/Control/Effect/Interpreter/Heftia/Fail.hs +26/−0
• src/Control/Effect/Interpreter/Heftia/Fresh.hs +54/−0
• src/Control/Effect/Interpreter/Heftia/Input.hs +62/−0
• src/Control/Effect/Interpreter/Heftia/KVStore.hs +65/−0
• src/Control/Effect/Interpreter/Heftia/NonDet.hs +158/−0
• src/Control/Effect/Interpreter/Heftia/Output.hs +98/−0
• src/Control/Effect/Interpreter/Heftia/Provider.hs +39/−0
• src/Control/Effect/Interpreter/Heftia/Provider/Implicit.hs +44/−0
• src/Control/Effect/Interpreter/Heftia/Reader.hs +72/−0
• src/Control/Effect/Interpreter/Heftia/Resource.hs +26/−0
• src/Control/Effect/Interpreter/Heftia/ShiftReset.hs +70/−0
• src/Control/Effect/Interpreter/Heftia/State.hs +120/−0
• src/Control/Effect/Interpreter/Heftia/Unlift.hs +34/−0
• src/Control/Effect/Interpreter/Heftia/Writer.hs +319/−0

@@ -8,3 +8,10 @@  * Redesign from scratch. * Released as a beta version.++## 0.3.0.0 -- 2024-09-01++* Added interpreters for 'Timer' effects.+* 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.

@@ -9,7 +9,7 @@  import Control.Effect (type (~>)) import Control.Effect.ExtensibleChurch (runEff, type (:!!))-import Control.Effect.Hefty (interposeK, interpretRec, interpretRecH)+import Control.Effect.Hefty (Elab, interposeK, interpretRec, interpretRecH) import Control.Monad.IO.Class (liftIO) import Data.Effect.TH (makeEffectF, makeEffectH) import Data.Function ((&))@@ -28,10 +28,10 @@     ResetFork :: Monoid w => f w -> ResetFork f w makeEffectH [''ResetFork] -applyResetFork :: Fork <| r => Int -> ResetFork ('[] :!! r) ~> '[] :!! r+applyResetFork :: Fork <| r => Int -> Elab ResetFork ('[] :!! r) applyResetFork numberOfFork (ResetFork m) =-    m & interposeK pure \k Fork -> do-        r <- mapM k [1 .. numberOfFork]+    m & interposeK pure \resume Fork -> do+        r <- mapM resume [1 .. numberOfFork]         pure $ mconcat r  main :: IO ()

@@ -6,10 +6,10 @@  import Control.Arrow ((>>>)) import Control.Effect.ExtensibleChurch (runEff, type (!!))-import Control.Effect.Handler.Heftia.Reader (runAsk, runLocal)-import Control.Effect.Handler.Heftia.ShiftReset (evalShift, runShift_)-import Control.Effect.Handler.Heftia.State (evalState) 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)

@@ -10,15 +10,27 @@  import Control.Arrow ((>>>)) import Control.Effect (type (<:), type (<<:), type (~>))-import Control.Effect.ExtensibleChurch (runEff, type (:!!))-import Control.Effect.Handler.Heftia.Reader (runReader)-import Control.Effect.Handler.Heftia.State (evalState)-import Control.Effect.Hefty (interposeRec, interposeRecH, interpretRec, interpretRecH, raise, raiseH)+import Control.Effect.ExtensibleFinal (runEff, type (!!), type (:!!))+import Control.Effect.Hefty (+    Elab,+    interposeRec,+    interposeRecH,+    interpretRec,+    interpretRecH,+    raise,+    raiseH,+    raiseUnder,+    reinterpretRecH,+    subsume,+ )+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 (ask, local)+import Data.Effect.Reader (LAsk, 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)@@ -26,11 +38,10 @@ import Data.Text qualified as T import Data.Text.IO qualified as T import Data.Time (UTCTime, getCurrentTime)-import Data.Time.Format.ISO8601 (iso8601Show)+import Data.Time.Format (defaultTimeLocale, formatTime)  data Log a where     Logging :: Text -> Log ()- makeEffectF [''Log]  logToIO :: (IO <| r, ForallHFunctor eh) => eh :!! LLog ': r ~> eh :!! r@@ -38,7 +49,6 @@  data Time a where     CurrentTime :: Time UTCTime- makeEffectF [''Time]  timeToIO :: (IO <| r, ForallHFunctor eh) => eh :!! LTime ': r ~> eh :!! r@@ -47,8 +57,11 @@ logWithTime :: (Log <| ef, Time <| ef, ForallHFunctor eh) => eh :!! ef ~> eh :!! ef logWithTime = interposeRec \(Logging msg) -> do     t <- currentTime-    logging $ "[" <> T.pack (show t) <> "] " <> msg+    logging $ "[" <> iso8601 t <> "] " <> msg +iso8601 :: UTCTime -> Text+iso8601 t = T.take 23 (T.pack $ formatTime defaultTimeLocale "%FT%T.%q" t) <> "Z"+ -- | An effect that introduces a scope that represents a chunk of logs. data LogChunk f (a :: Type) where     LogChunk ::@@ -63,27 +76,9 @@ runLogChunk :: ForallHFunctor eh => LogChunk ': eh :!! ef ~> eh :!! ef runLogChunk = interpretRecH \(LogChunk _ m) -> m --- | Limit the number of logs in a log chunk to the first @n@ logs.-limitLogChunk ::-    forall eh ef.-    (LogChunk <<| eh, Log <| ef) =>-    Int ->-    LogChunk ('[] :!! ef) ~> LogChunk ('[] :!! ef)-limitLogChunk n (LogChunk chunkName a) =-    LogChunk chunkName . evalState @Int 0 $-        raise a & interposeRec \(Logging msg) -> do-            count <- get-            when (count <= n) do-                if count == n-                    then logging "LOG OMITTED..."-                    else logging msg--                modify @Int (+ 1)- data FileSystem a where     Mkdir :: FilePath -> FileSystem ()-    WriteToFile :: FilePath -> String -> FileSystem ()-+    WriteToFile :: FilePath -> Text -> FileSystem () makeEffectF [''FileSystem]  runDummyFS :: (IO <| r, ForallHFunctor eh) => eh :!! LFileSystem ': r ~> eh :!! r@@ -91,7 +86,7 @@     Mkdir path ->         liftIO $ putStrLn $ "<runDummyFS> mkdir " <> path     WriteToFile path content ->-        liftIO $ putStrLn $ "<runDummyFS> 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 ::@@ -100,79 +95,167 @@     eh :!! ef ~> eh :!! ef saveLogChunk =     raise >>> raiseH-        >>> ( interposeRecH \(LogChunk chunkName a) -> do-                chunkBeginAt <- currentTime-                let dirName = iso8601Show chunkBeginAt ++ "-" ++ T.unpack chunkName-                local @FilePath (++ dirName ++ "/") do-                    logChunkPath <- ask-                    mkdir logChunkPath-                    a & interposeRec \(Logging msg) -> do-                        logAt <- currentTime-                        logging msg-                        writeToFile (logChunkPath ++ iso8601Show logAt ++ ".log") (show msg)-            )+        >>> hookCreateDirectory+        >>> hookWriteFile         >>> runReader @FilePath "./log/"+  where+    hookCreateDirectory+        , hookWriteFile ::+            (Local FilePath ': eh :!! LAsk FilePath ': ef)+                ~> (Local FilePath ': eh :!! LAsk FilePath ': ef)+    hookCreateDirectory =+        interposeRecH \(LogChunk chunkName a) -> logChunk chunkName do+            chunkBeginAt <- currentTime+            let dirName = T.unpack $ iso8601 chunkBeginAt <> "-" <> chunkName+            local @FilePath (++ dirName ++ "/") do+                logChunkPath <- ask+                mkdir logChunkPath+                a +    hookWriteFile =+        interposeRec \(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++elabLimitLogChunk :: Log <| ef => Int -> Elab LogChunk ('[LogChunk] :!! LLog ': ef)+elabLimitLogChunk n (LogChunk name a) =+    logChunk name do+        raise . raiseH $ limitLog $ runLogChunk $ limitLogChunk n a+  where+    limitLog :: Log <| ef => '[] :!! LLog ': ef ~> '[] :!! ef+    limitLog a' =+        evalState @Int 0 $+            raiseUnder a' & interpretRec \(Logging msg) -> do+                count <- get+                when (count < n) do+                    logging msg+                    when (count == n - 1) do+                        logging "Subsequent logs are omitted..."++                    modify @Int (+ 1)+ logExample :: (LogChunk <<: m, Log <: m, MonadIO m) => m ()-logExample =+logExample = do+    logging "out of chunk scope 1"+    logging "out of chunk scope 2"+    logging "out of chunk scope 3"+    logging "out of chunk scope 4"++    liftIO $ putStrLn "------"+     logChunk "scope1" do-        logging "foo"-        logging "bar"-        logging "baz"-        logging "qux"+        logging "in scope1 1"+        logging "in scope1 2"+        logging "in scope1 3"+        logging "in scope1 4"          liftIO $ putStrLn "------"          logChunk "scope2" do-            logging "hoge"-            logging "piyo"-            logging "fuga"-            logging "hogera"+            logging "in scope2 1"+            logging "in scope2 2"+            logging "in scope2 3"+            logging "in scope2 4"          liftIO $ putStrLn "------" -        logging "quux"-        logging "foobar"+        logging "in scope1 5"+        logging "in scope1 6" +saveThenLimit :: IO ()+saveThenLimit =+    logExample+        & saveLogChunk+        & limitLogChunk 2+        & subsume @LLog+        & runApp++limitThenSave :: IO ()+limitThenSave =+    logExample+        & limitLogChunk 2+        & subsume @LLog+        & saveLogChunk+        & runApp++runApp :: LogChunk !! FileSystem + Time + Log + IO ~> IO+runApp =+    runLogChunk+        >>> runDummyFS+        >>> logWithTime+        >>> timeToIO+        >>> logToIO+        >>> runEff+ main :: IO ()-main =-    runEff-        . logToIO-        . timeToIO-        . logWithTime-        . runDummyFS-        . runLogChunk-        . saveLogChunk-        $ do-            logExample+main = do+    putStrLn "# saveThenLimit"+    saveThenLimit+    putStrLn ""+    putStrLn "# limitThenSave"+    limitThenSave  {--<runDummyFS> mkdir ./log/2024-07-06T13:56:23.447829919Z-scope1/-[2024-07-06 13:56:23.448628515 UTC] foo-<runDummyFS> writeToFile ./log/2024-07-06T13:56:23.447829919Z-scope1/2024-07-06T13:56:23.448625419Z.log : "foo"-[2024-07-06 13:56:23.448932798 UTC] bar-<runDummyFS> writeToFile ./log/2024-07-06T13:56:23.447829919Z-scope1/2024-07-06T13:56:23.448930113Z.log : "bar"-[2024-07-06 13:56:23.448989065 UTC] baz-<runDummyFS> writeToFile ./log/2024-07-06T13:56:23.447829919Z-scope1/2024-07-06T13:56:23.448986289Z.log : "baz"-[2024-07-06 13:56:23.449036674 UTC] qux-<runDummyFS> writeToFile ./log/2024-07-06T13:56:23.447829919Z-scope1/2024-07-06T13:56:23.449035743Z.log : "qux"+# saveThenLimit+<runDummyFS> writeToFile ./log/2024-08-31T17:25:38.063Z.log : out of chunk scope 1+[2024-08-31T17:25:38.063Z] out of chunk scope 1+<runDummyFS> writeToFile ./log/2024-08-31T17:25:38.063Z.log : out of chunk scope 2+[2024-08-31T17:25:38.063Z] out of chunk scope 2+<runDummyFS> writeToFile ./log/2024-08-31T17:25:38.063Z.log : out of chunk scope 3+[2024-08-31T17:25:38.063Z] out of chunk scope 3+<runDummyFS> writeToFile ./log/2024-08-31T17:25:38.063Z.log : out of chunk scope 4+[2024-08-31T17:25:38.063Z] out of chunk scope 4 -------<runDummyFS> mkdir ./log/2024-07-06T13:56:23.447829919Z-scope1/2024-07-06T13:56:23.449090566Z-scope2/-[2024-07-06 13:56:23.44913009 UTC] hoge-<runDummyFS> writeToFile ./log/2024-07-06T13:56:23.447829919Z-scope1/2024-07-06T13:56:23.449127986Z.log : "hoge"-<runDummyFS> writeToFile ./log/2024-07-06T13:56:23.447829919Z-scope1/2024-07-06T13:56:23.449090566Z-scope2/2024-07-06T13:56:23.449125371Z.log : "hoge"-[2024-07-06 13:56:23.449215892 UTC] piyo-<runDummyFS> writeToFile ./log/2024-07-06T13:56:23.447829919Z-scope1/2024-07-06T13:56:23.449213508Z.log : "piyo"-<runDummyFS> writeToFile ./log/2024-07-06T13:56:23.447829919Z-scope1/2024-07-06T13:56:23.449090566Z-scope2/2024-07-06T13:56:23.449210612Z.log : "piyo"-[2024-07-06 13:56:23.449303087 UTC] fuga-<runDummyFS> writeToFile ./log/2024-07-06T13:56:23.447829919Z-scope1/2024-07-06T13:56:23.449300221Z.log : "fuga"-<runDummyFS> writeToFile ./log/2024-07-06T13:56:23.447829919Z-scope1/2024-07-06T13:56:23.449090566Z-scope2/2024-07-06T13:56:23.449298909Z.log : "fuga"-[2024-07-06 13:56:23.449383799 UTC] hogera-<runDummyFS> writeToFile ./log/2024-07-06T13:56:23.447829919Z-scope1/2024-07-06T13:56:23.449380502Z.log : "hogera"-<runDummyFS> writeToFile ./log/2024-07-06T13:56:23.447829919Z-scope1/2024-07-06T13:56:23.449090566Z-scope2/2024-07-06T13:56:23.44937926Z.log : "hogera"+<runDummyFS> mkdir ./log/2024-08-31T17:25:38.063Z-scope1/+<runDummyFS> writeToFile ./log/2024-08-31T17:25:38.063Z-scope1/2024-08-31T17:25:38.063Z.log : in scope1 1+[2024-08-31T17:25:38.063Z] in scope1 1+<runDummyFS> writeToFile ./log/2024-08-31T17:25:38.063Z-scope1/2024-08-31T17:25:38.063Z.log : in scope1 2+[2024-08-31T17:25:38.063Z] in scope1 2+[2024-08-31T17:25:38.064Z] Subsequent logs are omitted...+<runDummyFS> writeToFile ./log/2024-08-31T17:25:38.063Z-scope1/2024-08-31T17:25:38.064Z.log : in scope1 3+<runDummyFS> writeToFile ./log/2024-08-31T17:25:38.063Z-scope1/2024-08-31T17:25:38.064Z.log : in scope1 4 -------[2024-07-06 13:56:23.449513012 UTC] quux-<runDummyFS> writeToFile ./log/2024-07-06T13:56:23.447829919Z-scope1/2024-07-06T13:56:23.449510688Z.log : "quux"-[2024-07-06 13:56:23.449560241 UTC] foobar-<runDummyFS> writeToFile ./log/2024-07-06T13:56:23.447829919Z-scope1/2024-07-06T13:56:23.449558087Z.log : "foobar"+<runDummyFS> mkdir ./log/2024-08-31T17:25:38.063Z-scope1/2024-08-31T17:25:38.064Z-scope2/+<runDummyFS> writeToFile ./log/2024-08-31T17:25:38.063Z-scope1/2024-08-31T17:25:38.064Z-scope2/2024-08-31T17:25:38.064Z.log : in scope2 1+[2024-08-31T17:25:38.064Z] in scope2 1+<runDummyFS> writeToFile ./log/2024-08-31T17:25:38.063Z-scope1/2024-08-31T17:25:38.064Z-scope2/2024-08-31T17:25:38.064Z.log : in scope2 2+[2024-08-31T17:25:38.064Z] in scope2 2+[2024-08-31T17:25:38.064Z] Subsequent logs are omitted...+<runDummyFS> writeToFile ./log/2024-08-31T17:25:38.063Z-scope1/2024-08-31T17:25:38.064Z-scope2/2024-08-31T17:25:38.064Z.log : in scope2 3+<runDummyFS> writeToFile ./log/2024-08-31T17:25:38.063Z-scope1/2024-08-31T17:25:38.064Z-scope2/2024-08-31T17:25:38.064Z.log : in scope2 4+------+<runDummyFS> writeToFile ./log/2024-08-31T17:25:38.063Z-scope1/2024-08-31T17:25:38.064Z.log : in scope1 5+<runDummyFS> writeToFile ./log/2024-08-31T17:25:38.063Z-scope1/2024-08-31T17:25:38.064Z.log : in scope1 6++# limitThenSave+<runDummyFS> writeToFile ./log/2024-08-31T17:25:38.064Z.log : out of chunk scope 1+[2024-08-31T17:25:38.065Z] out of chunk scope 1+<runDummyFS> writeToFile ./log/2024-08-31T17:25:38.065Z.log : out of chunk scope 2+[2024-08-31T17:25:38.065Z] out of chunk scope 2+<runDummyFS> writeToFile ./log/2024-08-31T17:25:38.065Z.log : out of chunk scope 3+[2024-08-31T17:25:38.065Z] out of chunk scope 3+<runDummyFS> writeToFile ./log/2024-08-31T17:25:38.065Z.log : out of chunk scope 4+[2024-08-31T17:25:38.065Z] out of chunk scope 4+------+<runDummyFS> mkdir ./log/2024-08-31T17:25:38.065Z-scope1/+<runDummyFS> writeToFile ./log/2024-08-31T17:25:38.065Z-scope1/2024-08-31T17:25:38.065Z.log : in scope1 1+[2024-08-31T17:25:38.065Z] in scope1 1+<runDummyFS> writeToFile ./log/2024-08-31T17:25:38.065Z-scope1/2024-08-31T17:25:38.065Z.log : in scope1 2+[2024-08-31T17:25:38.065Z] in scope1 2+<runDummyFS> writeToFile ./log/2024-08-31T17:25:38.065Z-scope1/2024-08-31T17:25:38.065Z.log : Subsequent logs are omitted...+[2024-08-31T17:25:38.065Z] Subsequent logs are omitted...+------+<runDummyFS> writeToFile ./log/2024-08-31T17:25:38.065Z-scope1/2024-08-31T17:25:38.065Z.log : in scope2 1+[2024-08-31T17:25:38.065Z] in scope2 1+<runDummyFS> writeToFile ./log/2024-08-31T17:25:38.065Z-scope1/2024-08-31T17:25:38.065Z.log : in scope2 2+[2024-08-31T17:25:38.065Z] in scope2 2+<runDummyFS> writeToFile ./log/2024-08-31T17:25:38.065Z-scope1/2024-08-31T17:25:38.065Z.log : Subsequent logs are omitted...+[2024-08-31T17:25:38.065Z] Subsequent logs are omitted...+------ -}

@@ -11,11 +11,11 @@  import Control.Applicative ((<|>)) import Control.Effect.ExtensibleChurch ((:!!))-import Control.Effect.Handler.Heftia.Except (runCatch, runThrow)-import Control.Effect.Handler.Heftia.NonDet (runChooseH, runNonDet)-import Control.Effect.Handler.Heftia.State (evalState)-import Control.Effect.Handler.Heftia.Writer (elaborateWriterPre, runTell) 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 Data.Effect.Except (Catch, Throw, catch, throw) import Data.Effect.NonDet (ChooseH, Empty) import Data.Effect.State (State, get, put)

@@ -6,8 +6,8 @@  import Control.Effect (type (<:), type (<<:)) import Control.Effect.ExtensibleChurch (runEff)-import Control.Effect.Handler.Heftia.Writer (elabWriterPost, elabWriterPre, runTell) import Control.Effect.Hefty (interpretRecH)+import Control.Effect.Interpreter.Heftia.Writer (elabWriterPost, elabWriterPre, runTell) import Control.Monad.IO.Class (liftIO) import Data.Effect.Writer (Tell, WriterH, censor, tell) 

@@ -27,8 +27,57 @@  **We are looking forward to your feedback!** +## Installation+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:++    * `LambdaCase`+    * `DerivingStrategies`+    * `DataKinds`+    * `TypeFamilies`+    * `BlockArguments`+    * `FunctionalDependencies`+    * `RecordWildCards`+    * `DefaultSignatures`+    * `PatternSynonyms`++Example .cabal:++```+...+    build-depends:+        ...+        heftia-effects ^>= 0.2,+        ghc-typelits-knownnat ^>= 0.7,++    default-language: GHC2021++    default-extensions:+        ...+        LambdaCase,+        DerivingStrategies,+        DataKinds,+        TypeFamilies,+        BlockArguments,+        FunctionalDependencies,+        RecordWildCards,+        DefaultSignatures,+        PatternSynonyms,+        TemplateHaskell,+        PartialTypeSignatures,+        AllowAmbiguousTypes++    ghc-options: ... -fplugin GHC.TypeLits.KnownNat.Solver+...+```++This library has been tested to work with GHC 9.2.8.+ ## Getting Started-To run the [SemanticsZoo example](heftia-effects/Example/SemanticsZoo/Main.hs):+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@@ -63,7 +112,7 @@ 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](heftia-effects/Example/Continuation/Main.hs).+the [example code](https://github.com/sayo-hs/heftia/blob/v0.3.0/heftia-effects/Example/Continuation/Main.hs).  ### Two interpretations of the `censor` effect for Writer @@ -116,7 +165,7 @@ Post-applying: Hello world!! ``` -For more details, please refer to the [complete code](https://github.com/sayo-hs/heftia/blob/develop/heftia-effects/Example/Writer/Main.hs) and the [implementation of the elaborator](https://github.com/sayo-hs/heftia/blob/develop/heftia-effects/src/Control/Effect/Handler/Heftia/Writer.hs).+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).  Furthermore, the structure of Heftia is theoretically straightforward, with ad-hoc elements being eliminated.@@ -127,47 +176,34 @@ Heftia is the current main focus of the [Sayo Project](https://github.com/sayo-hs).  ## Documentation-The example codes are located in the [heftia-effects/Example/](heftia-effects/Example/) directory.+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 -~~Examples with explanations can be found in the [docs/examples/](https://github.com/sayo-hs/heftia/tree/master/docs/examples) directory.~~ Documents have become outdated.-Please wait for the documentation for the new version to be written.--## Limitation and how to avoid it-### The *reset* behavior of the scopes held by unhandled higher-order effects-When attempting to interpret an effect while there are unhandled higher-order effects present, you cannot obtain delimited continuations beyond the action scope held by these unhandled higher-order effects.-It appears as if a *reset* (in the sense of *shift/reset*) is applied to each of the scopes still held by the remaining unhandled higher-order effects.--In other words, to obtain delimited continuations beyond their scope, it is necessary to first handle and eliminate all higher-order effects that hold those scopes,-and then handle the effect targeted for stateful interpretation in that order.-For this purpose, it might sometimes be possible to use *multi-layering*. For an example of multi-layering,-see `handleReaderThenShift` defined in [Example/Continuation2](https://github.com/sayo-hs/heftia/blob/8f71a2d4e6125018b64cbbacd32151565a29046d/heftia-effects/Example/Continuation2/Main.hs)-(particularly, the type signature of `prog` within it).-For more details, please refer to the documentation of the `interpretRec` family of functions.+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.  ## Comparison  * Higher-Order Effects: Does it support higher-order effects? * Delimited Continuation: The ability to manipulate delimited continuations.-* Statically Typed Set of Effects: For a term representing an effectful program, is it possible to statically decidable a type that enumerates all the effects the program may produce?+* Effect System: For a term representing an effectful program, is it possible to statically decidable a type that enumerates all the effects the program may produce? * Purely Monadic: Is an effectful program represented as a transparent data structure that is a monad, and can it be interpreted into other data types using only pure operations without side effects or `unsafePerformIO`? * Dynamic Effect Rewriting: Can an effectful program have its internal effects altered afterwards (by functions typically referred to as `handle with`, `intercept`, `interpose`, `transform`, `translate`, or `rewrite`) ? * Performance: Time complexity or space complexity. -| Library or Language | Higher-Order Effects | Delimited Continuation | Statically Typed Set of Effects                 | Purely Monadic                    | Dynamic Effect Rewriting | Performance (TODO) |-| ------------------- | -------------------- | ---------------------- | ----------------------------------------------- | --------------------------------- | ------------------------ | ------------------ |-| Heftia              | Yes [^1]             | Multi-shot             | Yes                                             | Yes (also Applicative and others) | Yes                      | ?                  |-| freer-simple        | No                   | Multi-shot             | Yes                                             | Yes                               | Yes                      | ?                  |-| Polysemy            | Yes                  | No                     | Yes                                             | Yes                               | Yes                      | ?                  |-| Effectful           | Yes                  | No                     | Yes                                             | No (based on the `IO` monad)      | Yes                      | ?                  |-| eff                 | Yes                  | Multi-shot?            | Yes                                             | No (based on the `IO` monad)      | Yes                      | Fast               |-| mtl                 | Yes                  | Multi-shot (`ContT`)   | Yes                                             | Yes                               | No                       | ?                  |-| fused-effects       | Yes                  | No?                    | Yes                                             | Yes                               | No                       | ?                  |-| koka-lang           | No?                  | Multi-shot             | Yes                                             | No (language built-in)            | ?                        | ?                  |-| OCaml-lang 5        | Yes                  | One-shot               | No [^2]                                         | No (language built-in)            | ?                        | ?                  |+| Library or Language | Higher-Order Effects | Delimited Continuation | Effect System | Purely Monadic                    | Dynamic Effect Rewriting | Performance (TODO) |+| ------------------- | -------------------- | ---------------------- | --------------| --------------------------------- | ------------------------ | ------------------ |+| Heftia              | Yes                  | Multi-shot             | Yes           | Yes (also Applicative and others) | Yes                      | ?                  |+| freer-simple        | No                   | Multi-shot             | Yes           | Yes                               | Yes                      | ?                  |+| Polysemy            | Yes                  | No                     | Yes           | Yes                               | Yes                      | ?                  |+| Effectful           | Yes                  | No                     | Yes           | No (based on the `IO` monad)      | Yes                      | ?                  |+| eff                 | Yes                  | Multi-shot?            | Yes           | No (based on the `IO` monad)      | Yes                      | Fast               |+| mtl                 | Yes                  | Multi-shot (`ContT`)   | Yes           | Yes                               | No                       | ?                  |+| fused-effects       | Yes                  | No?                    | Yes           | Yes                               | No                       | ?                  |+| koka-lang           | No [^2]              | Multi-shot             | Yes           | No (language built-in)            | Yes                      | ?                  |+| OCaml-lang 5        | ?                    | One-shot               | No [^3]       | No (language built-in)            | ?                        | ?                  | -[^1]: limitation: https://github.com/sayo-hs/heftia?tab=readme-ov-file#the-reset-behavior-of-the-scopes-held-by-unhandled-higher-order-effects-[^2]: potential for 'unhandled' runtime errors+[^2]: https://gist.github.com/ymdryo/6fb2f7f4020c6fcda98ccc67c090dc75+[^3]: Effects do not appear in the type signature and can potentially cause unhandled errors at runtime  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.@@ -185,7 +221,7 @@  * 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 unhandled.+    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. @@ -198,20 +234,19 @@ ## Future Plans * Enriching the documentation and tests * Completing missing definitions such as-    * `raise`, `raiseUnder`, and `subsume` for arbitrary numbers of effects by type classes.     * more patterns of interpret & transform function-families.-    * handlers for the `Accum` and others effect classes+    * interpreters for the `Accum` and others effect classes      and others. * Benchmarking  ## License-The license is MPL 2.0. Please refer to the [NOTICE](https://github.com/sayo-hs/heftia/blob/develop/NOTICE).-Additionally, this README.md and the documents under the `docs`/`docs-ja` directory are licensed+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.  ## Your contributions are welcome!-Please see [CONTRIBUTING.md](https://github.com/sayo-hs/heftia/blob/develop/CONTRIBUTING.md).+Please see [CONTRIBUTING.md](https://github.com/sayo-hs/heftia/blob/v0.3.0/CONTRIBUTING.md).  ## Credits Parts of this project have been inspired by the following resources:

@@ -1,6 +1,6 @@ cabal-version:      2.4 name:               heftia-effects-version:            0.2.0.0+version:            0.3.0.0  -- A short (one-line) description of the package. synopsis: higher-order effects done right@@ -55,8 +55,8 @@     build-depends:         base ^>= 4.16,         ghc-typelits-knownnat ^>= 0.7,-        data-effects ^>= 0.1,-        heftia ^>= 0.2,+        data-effects ^>= 0.1.1,+        heftia ^>= 0.3,      ghc-options: -Wall -fplugin GHC.TypeLits.KnownNat.Solver @@ -64,22 +64,23 @@     import: common-base      exposed-modules:-        Control.Effect.Handler.Heftia.Reader-        Control.Effect.Handler.Heftia.Writer-        Control.Effect.Handler.Heftia.State-        Control.Effect.Handler.Heftia.Except-        Control.Effect.Handler.Heftia.ShiftReset-        Control.Effect.Handler.Heftia.NonDet-        Control.Effect.Handler.Heftia.Coroutine-        Control.Effect.Handler.Heftia.Input-        Control.Effect.Handler.Heftia.Output-        Control.Effect.Handler.Heftia.Provider-        Control.Effect.Handler.Heftia.Provider.Implicit-        Control.Effect.Handler.Heftia.Resource-        Control.Effect.Handler.Heftia.Unlift-        Control.Effect.Handler.Heftia.KVStore-        Control.Effect.Handler.Heftia.Fresh-        Control.Effect.Handler.Heftia.Fail+        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      reexported-modules:         Control.Effect.Hefty,@@ -126,6 +127,7 @@         Data.Effect.KVStore,         Data.Effect.Fresh,         Data.Effect.Fail,+        Data.Effect.Concurrent.Timer,      -- Modules included in this executable, other than Main.     -- other-modules:@@ -139,6 +141,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 @@ -146,11 +151,16 @@     import: common-base      main-is: Driver.hs+    other-modules:+     hs-source-dirs: test+     build-depends:         heftia-effects,         tasty                         ^>= 1.4,-        tasty-hunit                   ^>= 0.10,+        tasty-hspec,+        hspec,+        unliftio,      build-tool-depends:         tasty-discover:tasty-discover@@ -183,8 +193,6 @@         heftia-effects,         text ^>= 1.2.5,         time ^>= 1.11.1,-        loglevel ^>= 0.1.0,-        extra ^>= 1.7.14,  executable Continuation     import: common-base

@@ -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.Handler.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,114 +0,0 @@--- This Source Code Form is subject to the terms of the Mozilla Public--- License, v. 2.0. If a copy of the MPL was not distributed with this--- file, You can obtain one at https://mozilla.org/MPL/2.0/.--{- |-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.Handler.Heftia.Except where--import Control.Arrow ((>>>))-import Control.Effect (type (~>))-import Control.Effect.Hefty (-    Eff,-    Elab,-    interposeK,-    interposeT,-    interpretK,-    interpretRecH,-    interpretT,- )-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.Function ((&))-import Data.Hefty.Union (Member, Union)---- | 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

@@ -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.Handler.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.Handler.Heftia.Fresh where--import Control.Arrow ((>>>))-import Control.Effect (type (~>))-import Control.Effect.Handler.Heftia.State (runState)-import Control.Effect.Hefty (Eff, interpret, raiseUnder)-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.Handler.Heftia.Input where--import Control.Arrow ((>>>))-import Control.Effect (type (~>))-import Control.Effect.Handler.Heftia.State (evalState)-import Control.Effect.Hefty (Eff, interpret, interpretRec, raiseUnder)-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.Handler.Heftia.KVStore where--import Control.Arrow ((>>>))-import Control.Effect (type (~>))-import Control.Effect.Handler.Heftia.State (runState)-import Control.Effect.Hefty (Eff, interpret, raiseUnder)-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.Handler.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.Handler.Heftia.Output where--import Control.Arrow ((>>>))-import Control.Effect (type (~>))-import Control.Effect.Handler.Heftia.State (runState)-import Control.Effect.Handler.Heftia.Writer (runTell, runTellA)-import Control.Effect.Hefty (Eff, interpret, interpretRec, raiseUnder, send0)-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.Handler.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.Handler.Heftia.Provider.Implicit where--import Control.Effect (type (~>))-import Control.Effect.Handler.Heftia.Reader (runAsk)-import Control.Effect.Hefty (Eff, Elab, raise)-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.Handler.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.Handler.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.Handler.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.Handler.Heftia.State where--import Control.Arrow ((>>>))-import Control.Effect (type (~>))-import Control.Effect.Handler.Heftia.Reader (runAsk)-import Control.Effect.Hefty (Eff, injectF, interpose, interposeT, interpret, interpretFin, interpretK, raiseUnder)-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.Handler.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.Handler.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,54 @@+-- 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

@@ -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/.++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)

@@ -0,0 +1,135 @@+-- 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 #-}

@@ -0,0 +1,26 @@+-- 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 #-}

@@ -0,0 +1,54 @@+-- 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)

@@ -0,0 +1,62 @@+-- 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

@@ -0,0 +1,65 @@+-- 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

@@ -0,0 +1,158 @@+-- 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

@@ -0,0 +1,98 @@+-- 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

@@ -0,0 +1,39 @@+-- 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 #-}

@@ -0,0 +1,44 @@+-- This Source Code Form is subject to the terms of the Mozilla Public+-- License, v. 2.0. If a copy of the MPL was not distributed with this+-- file, You can obtain one at https://mozilla.org/MPL/2.0/.++{- |+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 #-}

@@ -0,0 +1,72 @@+-- 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 #-}

@@ -0,0 +1,26 @@+-- 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

@@ -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/.++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 #-}

@@ -0,0 +1,120 @@+{-# 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)

@@ -0,0 +1,34 @@+-- 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 #-}

@@ -0,0 +1,319 @@+{-# 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