[add] the entire code to the example 3.

This commit is contained in:
Yamada Ryo 2023-09-16 15:23:52 +09:00
parent 7504aaedfd
commit de1c7e6052
No known key found for this signature in database
GPG Key ID: AAE3C7A542B02DBF
2 changed files with 53 additions and 0 deletions

View File

@ -203,6 +203,8 @@ main = runFreerEffects $ do
さらに、ハンドル時はタグを外して素の`TeletypeI`に戻すために、`untag @TTY1`を使用している。
将来のclassy-effectsのバージョンでは、例えば`readTTY & tag @TTY1`を`readTTY' @TTY1`のように短く書けるようになる予定である。
## コード全体
コードの全体は以下のようになる。暗黙的に有効になっているGHC拡張が多いことに注意せよ。

View File

@ -118,3 +118,54 @@ Haskell上でEffect Systemを実現するライブラリは数多くあるが、
有名な「Algebraic Effects and Handlers」で可能なこと例えば限定継続の取り出しとそれを用いたモジュラーなエフェクトのハンドリングをほぼフルでエミュレートできるのは、
筆者の知る限りではいまのところHefty Algebrasに基づくこの方式のみのはずである。
## コード全体
```hs
{-# LANGUAGE TemplateHaskell #-}
module Main where
import Control.Effect.Class (sendIns, type (~>))
import Control.Effect.Class.Machinery.TH (makeEffectF, makeEffectH)
import Control.Effect.Freer (Fre, interposeK, interpret, runFreerEffects, type (<|))
import Control.Effect.Heftia (Elaborator, runElaborate)
import Control.Monad.Trans.Heftia.Church (HeftiaChurchT)
import Data.Function ((&))
import Data.Hefty.Sum (SumUnionH)
import Data.Hefty.Union (UnionH (absurdUnionH, (|+:)))
type ForkID = Int
class Fork f where
fork :: f ForkID
makeEffectF ''Fork
runForkSingle :: Monad m => Fre (ForkI ': r) m ~> Fre r m
runForkSingle = interpret \Fork -> pure 0
class DelimitFork f where
delimitFork :: Monoid w => f w -> f w
makeEffectH ''DelimitFork
applyDelimitFork :: (ForkI <| es, Monad m) => Int -> Elaborator DelimitForkS (Fre es m)
applyDelimitFork numberOfFork (DelimitFork m) =
m & interposeK pure \k Fork -> do
r <- mapM k [1 .. numberOfFork]
pure $ mconcat r
main :: IO ()
main =
runFreerEffects
. runForkSingle
. runElaborate @_ @HeftiaChurchT @SumUnionH (applyDelimitFork 4 |+: absurdUnionH)
$ do
sendIns . putStrLn . (("[out of scope] " ++) . show) =<< fork
s <- delimitFork do
fid1 <- fork
fid2 <- fork
sendIns $ putStrLn $ "[delimited continuation of `fork`] Fork ID: " ++ show (fid1, fid2)
pure $ show (fid1, fid2)
sendIns $ putStrLn $ "scope exited. result: " ++ s
```