sayo-hs/heftia
1
1
Fork 0
mirror of https://github.com/sayo-hs/heftia.git synced 2024-11-26 23:05:04 +03:00
Code Issues Actions Packages Projects Releases Wiki Activity

[fix] Use 'liftIO' instead of 'sendIns' in the examples.

Browse Source
This commit is contained in:
Yamada Ryo 2024-07-09 00:52:13 +09:00
parent 020447a2c9
commit c2d12f72b8
No known key found for this signature in database
GPG Key ID: AAE3C7A542B02DBF
7 changed files with 35 additions and 30 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

4
README.md
View File

@ -75,8 +75,8 @@ are some examples:
. interpretH (elaborateWriterPost @String)
$ censorHello
sendIns $ putStrLn $ "Pre-applying: " <> sPre
sendIns $ putStrLn $ "Post-applying: " <> sPost
liftIO $ putStrLn $ "Pre-applying: " <> sPre
liftIO $ putStrLn $ "Post-applying: " <> sPost
```
Using the `elaborateWriterPre` elaborator, you'll get "Goodbye world!", whereas with the `elaborateWriterPost` elaborator, you'll get "Hello world!!".

9
heftia-effects/Example/Continuation/Main.hs
View File

@ -7,9 +7,10 @@
module Main where
import Control.Effect (SendIns (sendIns), type (~>))
import Control.Effect (type (~>))
import Control.Effect.ExtensibleChurch (runEff, type (:!!))
import Control.Effect.Hefty (interposeK, interpretH, interpretRec)
import Control.Monad.IO.Class (liftIO)
import Data.Effect.TH (makeEffectF, makeEffectH)
import Data.Function ((&))
import Data.Hefty.Extensible (ForallHFunctor, type (<|))
@ -39,13 +40,13 @@ main =
. runForkSingle
. interpretH (applyResetFork 4)
$ do
sendIns . putStrLn . (("[out of scope] " ++) . show) =<< fork
liftIO . putStrLn . (("[out of scope] " ++) . show) =<< fork
s <- resetFork do
fid1 <- fork
fid2 <- fork
sendIns $ putStrLn $ "[delimited continuation of `fork`] Fork ID: " ++ show (fid1, fid2)
liftIO $ putStrLn $ "[delimited continuation of `fork`] Fork ID: " ++ show (fid1, fid2)
pure $ show (fid1, fid2)
sendIns $ putStrLn $ "scope exited. result: " ++ s
liftIO $ putStrLn $ "scope exited. result: " ++ s
{-
[out of scope] 0

10
heftia-effects/Example/Continuation2/Main.hs
View File

@ -4,13 +4,13 @@
module Main where
import Control.Effect (sendIns)
import Control.Effect.ExtensibleChurch (runEff, type (!!))
import Control.Effect.Handler.Heftia.Reader (elaborateLocal, interpretAsk)
import Control.Effect.Handler.Heftia.ShiftReset (Shift, Shift_, getCC, getCC_, runShift, runShift_)
import Control.Effect.Handler.Heftia.State (evalState)
import Control.Effect.Hefty (interpretH, send1, type ($))
import Control.Monad.Extra (whenM)
import Control.Monad.IO.Class (liftIO)
import Data.Effect.HFunctor ((:+:))
import Data.Effect.Reader (Ask, Local, ask, local)
import Data.Effect.State (State, get, modify)
@ -72,12 +72,12 @@ elaborateLocalThenShift =
prog = do
k <- send1 getCC
env <- ask @Double
send1 $ sendIns $ putStrLn $ "[local scope outer] env = " ++ show env
send1 $ liftIO $ putStrLn $ "[local scope outer] env = " ++ show env
local @Double (* 2) do
whenM (send1 (get @Int) <&> (< 5)) do
send1 $ modify @Int (+ 1)
env' <- ask @Double
send1 $ sendIns $ putStrLn $ "[local scope inner] env = " ++ show env'
send1 $ liftIO $ putStrLn $ "[local scope inner] env = " ++ show env'
send1 k
elaborateShiftThenLocal :: IO ()
@ -93,10 +93,10 @@ elaborateShiftThenLocal = do
prog = do
k <- getCC_
env <- ask @Double
sendIns $ putStrLn $ "[local scope outer] env = " ++ show env
liftIO $ putStrLn $ "[local scope outer] env = " ++ show env
local @Double (* 2) do
whenM (get @Int <&> (< 5)) do
modify @Int (+ 1)
env' <- ask @Double
sendIns $ putStrLn $ "[local scope inner] env = " ++ show env'
liftIO $ putStrLn $ "[local scope inner] env = " ++ show env'
k

9
heftia-effects/Example/KeyedEffects/Main.hs
View File

@ -7,10 +7,11 @@
module Main where
import Control.Effect (SendIns (sendIns), type (~>))
import Control.Effect (type (~>))
import Control.Effect.ExtensibleChurch (runEff, type (:!!))
import Control.Effect.Hefty (interposeRec, interpretRec, unkeyEff)
import Control.Effect.Key (SendInsBy)
import Control.Monad.IO.Class (liftIO)
import Data.Effect.Key (unKey, type (#>))
import Data.Effect.TH (makeEffectF)
import Data.Hefty.Extensible (ForallHFunctor, MemberBy, type (<|))
@ -23,8 +24,8 @@ makeEffectF [''Teletype]
teletypeToIO :: (IO <| r, ForallHFunctor eh) => eh :!! LTeletype ': r ~> eh :!! r
teletypeToIO = interpretRec \case
ReadTTY -> sendIns getLine
WriteTTY msg -> sendIns $ putStrLn msg
ReadTTY -> liftIO getLine
WriteTTY msg -> liftIO $ putStrLn msg
echo :: (SendInsBy "tty1" Teletype m, Monad m) => m ()
echo = do
@ -41,5 +42,5 @@ strong =
main :: IO ()
main = runEff do
sendIns $ putStrLn "Please enter something..."
liftIO $ putStrLn "Please enter something..."
teletypeToIO . unkeyEff @"tty1" . strong . strong $ echo

17
heftia-effects/Example/Logging/Main.hs
View File

@ -9,12 +9,13 @@
module Main where
import Control.Arrow ((>>>))
import Control.Effect (sendIns, type (<:), type (<<:), type (~>))
import Control.Effect (type (<:), type (<<:), type (~>))
import Control.Effect.ExtensibleChurch (runEff, type (:!!))
import Control.Effect.Handler.Heftia.Reader (interpretReader)
import Control.Effect.Handler.Heftia.State (evalState)
import Control.Effect.Hefty (interposeRec, interposeRecH, interpretRec, interpretRecH, raise, raiseH)
import Control.Monad (when)
import Control.Monad.IO.Class (MonadIO, liftIO)
import Data.Effect.Reader (ask, local)
import Data.Effect.State (get, modify)
import Data.Effect.TH (makeEffectF, makeEffectH)
@ -33,7 +34,7 @@ data Log a where
makeEffectF [''Log]
logToIO :: (IO <| r, ForallHFunctor eh) => eh :!! LLog ': r ~> eh :!! r
logToIO = interpretRec \(Logging msg) -> sendIns $ T.putStrLn msg
logToIO = interpretRec \(Logging msg) -> liftIO $ T.putStrLn msg
data Time a where
CurrentTime :: Time UTCTime
@ -41,7 +42,7 @@ data Time a where
makeEffectF [''Time]
timeToIO :: (IO <| r, ForallHFunctor eh) => eh :!! LTime ': r ~> eh :!! r
timeToIO = interpretRec \CurrentTime -> sendIns getCurrentTime
timeToIO = interpretRec \CurrentTime -> liftIO getCurrentTime
logWithTime :: (Log <| ef, Time <| ef, ForallHFunctor eh) => eh :!! ef ~> eh :!! ef
logWithTime = interposeRec \(Logging msg) -> do
@ -88,9 +89,9 @@ makeEffectF [''FileSystem]
runDummyFS :: (IO <| r, ForallHFunctor eh) => eh :!! LFileSystem ': r ~> eh :!! r
runDummyFS = interpretRec \case
Mkdir path ->
sendIns $ putStrLn $ "<runDummyFS> mkdir " <> path
liftIO $ putStrLn $ "<runDummyFS> mkdir " <> path
WriteToFile path content ->
sendIns $ putStrLn $ "<runDummyFS> writeToFile " <> path <> " : " <> content
liftIO $ putStrLn $ "<runDummyFS> writeToFile " <> path <> " : " <> content
-- | Create directories according to the log-chunk structure and save one log in one file.
saveLogChunk ::
@ -112,7 +113,7 @@ saveLogChunk =
)
>>> interpretReader @FilePath "./log/"
logExample :: (LogChunk <<: m, Log <: m, IO <: m, Monad m) => m ()
logExample :: (LogChunk <<: m, Log <: m, MonadIO m) => m ()
logExample =
logChunk "scope1" do
logging "foo"
@ -120,7 +121,7 @@ logExample =
logging "baz"
logging "qux"
sendIns $ putStrLn "------"
liftIO $ putStrLn "------"
logChunk "scope2" do
logging "hoge"
@ -128,7 +129,7 @@ logExample =
logging "fuga"
logging "hogera"
sendIns $ putStrLn "------"
liftIO $ putStrLn "------"
logging "quux"
logging "foobar"

9
heftia-effects/Example/Teletype/Main.hs
View File

@ -11,9 +11,10 @@ The original of this example can be found at polysemy.
-}
module Main where
import Control.Effect (SendIns (sendIns), type (<:), type (~>))
import Control.Effect (type (<:), type (~>))
import Control.Effect.ExtensibleChurch (runEff, type (:!!))
import Control.Effect.Hefty (interposeRec, interpretRec, untagEff)
import Control.Monad.IO.Class (liftIO)
import Data.Effect.TH (makeEffectF)
import Data.Effect.Tag (Tag (unTag), type (#))
import Data.Hefty.Extensible (ForallHFunctor, type (<|))
@ -26,8 +27,8 @@ makeEffectF [''Teletype]
teletypeToIO :: (IO <| r, ForallHFunctor eh) => eh :!! LTeletype ': r ~> eh :!! r
teletypeToIO = interpretRec \case
ReadTTY -> sendIns getLine
WriteTTY msg -> sendIns $ putStrLn msg
ReadTTY -> liftIO getLine
WriteTTY msg -> liftIO $ putStrLn msg
echo :: (Teletype # "tty1" <: m, Monad m) => m ()
echo = do
@ -44,5 +45,5 @@ strong =
main :: IO ()
main = runEff do
sendIns $ putStrLn "Please enter something..."
liftIO $ putStrLn "Please enter something..."
teletypeToIO . untagEff @"tty1" . strong . strong $ echo

7
heftia-effects/Example/Writer/Main.hs
View File

@ -4,10 +4,11 @@
module Main where
import Control.Effect (sendIns, type (<:), type (<<:))
import Control.Effect (type (<:), type (<<:))
import Control.Effect.ExtensibleChurch (runEff)
import Control.Effect.Handler.Heftia.Writer (elaborateWriterPost, elaborateWriterPre, interpretTell)
import Control.Effect.Hefty (interpretH)
import Control.Monad.IO.Class (liftIO)
import Data.Effect.Writer (Tell, WriterH, censor, tell)
hello :: (Tell String <: m, Monad m) => m ()
@ -40,8 +41,8 @@ main = runEff do
. interpretH (elaborateWriterPost @String)
$ censorHello
sendIns $ putStrLn $ "Pre-applying: " <> sPre
sendIns $ putStrLn $ "Post-applying: " <> sPost
liftIO $ putStrLn $ "Pre-applying: " <> sPre
liftIO $ putStrLn $ "Post-applying: " <> sPost
{-
Pre-applying: Goodbye world!