mirror of
https://github.com/sayo-hs/heftia.git
synced 2024-11-27 15:45:19 +03:00
[add] the entire code to the example 3.
This commit is contained in:
parent
7504aaedfd
commit
de1c7e6052
@ -203,6 +203,8 @@ main = runFreerEffects $ do
|
||||
|
||||
さらに、ハンドル時はタグを外して素の`TeletypeI`に戻すために、`untag @TTY1`を使用している。
|
||||
|
||||
将来のclassy-effectsのバージョンでは、例えば`readTTY & tag @TTY1`を`readTTY' @TTY1`のように短く書けるようになる予定である。
|
||||
|
||||
## コード全体
|
||||
|
||||
コードの全体は以下のようになる。暗黙的に有効になっているGHC拡張が多いことに注意せよ。
|
||||
|
@ -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
|
||||
```
|
||||
|
Loading…
Reference in New Issue
Block a user