diff --git a/heftia-effects/Example/Continuation/Main.hs b/heftia-effects/Example/Continuation/Main.hs index ce9b85a..e2ab137 100644 --- a/heftia-effects/Example/Continuation/Main.hs +++ b/heftia-effects/Example/Continuation/Main.hs @@ -21,8 +21,8 @@ class Fork f where fork :: f ForkID makeEffectF ''Fork -runFork :: Monad m => Fre (ForkI ': r) m ~> Fre r m -runFork = interpret \Fork -> pure 0 +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 @@ -56,7 +56,7 @@ runDelimitFork numberOfFork = main :: IO () main = runFreerEffects - . runFork + . runForkSingle . runElaborate @_ @HeftiaChurchT @SumUnionH (applyDelimitFork 4 |+: absurdUnionH) $ do sendIns . putStrLn . (("[out of scope] " ++) . show) =<< fork diff --git a/heftia-effects/Example/Logging/Main.hs b/heftia-effects/Example/Logging/Main.hs index 89efcdb..bd9c7a3 100644 --- a/heftia-effects/Example/Logging/Main.hs +++ b/heftia-effects/Example/Logging/Main.hs @@ -7,7 +7,7 @@ module Main where -import Control.Effect.Class (sendIns, type (~>)) +import Control.Effect.Class (sendIns, type (<:), type (~>)) import Control.Effect.Class.Machinery.HFunctor (HFunctor) import Control.Effect.Class.Machinery.TH (makeEffectF, makeEffectH) import Control.Effect.Class.Reader (Ask, AskI, LocalS, ask, local) @@ -49,7 +49,7 @@ class Log f where makeEffectF ''Log logToIO :: - (IO <| r, Ask LogLevel (Fre r m), Monad m) => + (IO <: Fre r m, Ask LogLevel (Fre r m), Monad m) => Fre (LogI ': r) m ~> Fre r m logToIO = interpret \case Log level msg -> do @@ -61,7 +61,7 @@ class Time f where currentTime :: f UTCTime makeEffectF ''Time -timeToIO :: (IO <| r, Monad m) => Fre (TimeI ': r) m ~> Fre r m +timeToIO :: (IO <: Fre r m, Monad m) => Fre (TimeI ': r) m ~> Fre r m timeToIO = interpret \case CurrentTime -> sendIns getCurrentTime @@ -112,7 +112,7 @@ class FileSystem f where makeEffectF ''FileSystem -runDummyFS :: (IO <| r, Monad m) => Fre (FileSystemI ': r) m ~> Fre r m +runDummyFS :: (IO <: Fre r m, Monad m) => Fre (FileSystemI ': r) m ~> Fre r m runDummyFS = interpret \case Mkdir path -> sendIns $ putStrLn $ " mkdir " <> path WriteFS path content -> sendIns $ putStrLn $ " writeFS " <> path <> " : " <> content @@ -121,8 +121,8 @@ saveLogChunk :: forall es es' m. ( LogChunkS <<| es , LogI <| es' - , FileSystemI <| es' - , TimeI <| es' + , FileSystem (Fre es' m) + , Time (Fre es' m) , Monad m , HFunctor (SumH es) ) => @@ -137,14 +137,14 @@ saveLogChunk = ~> Hef (LocalS FilePath ': es) (Fre (AskI FilePath ': es') m) interposeLogChunk = interposeH \(LogChunk a) -> logChunk do - chunkBeginAt <- liftLowerH currentTime + chunkBeginAt <- currentTime & raise & liftLowerH local @FilePath (++ iso8601Show chunkBeginAt ++ "/") do - newLogChunkDir <- liftLowerH ask - liftLowerH $ mkdir newLogChunkDir + newLogChunkDir <- ask & liftLowerH + mkdir newLogChunkDir & raise & liftLowerH a & hoistInterpose \(Log level msg) -> do - logAt <- currentTime + logAt <- currentTime & raise saveDir <- ask - writeFS (saveDir ++ iso8601Show logAt ++ ".log") $ show (level, msg) + writeFS (saveDir ++ iso8601Show logAt ++ ".log") (show (level, msg)) & raise log level msg main :: IO () diff --git a/heftia-effects/Example/Teletype/Main.hs b/heftia-effects/Example/Teletype/Main.hs index 172a758..b8176ec 100644 --- a/heftia-effects/Example/Teletype/Main.hs +++ b/heftia-effects/Example/Teletype/Main.hs @@ -10,7 +10,7 @@ The original of this example can be found at polysemy. -} module Main where -import Control.Effect.Class (SendIns, sendIns, type (~>)) +import Control.Effect.Class (sendIns, type (<:), type (~>)) import Control.Effect.Class.Machinery.TH (makeEffectF) import Control.Effect.Freer (Fre, interpose, interpret, runFreerEffects, type (<|)) @@ -20,7 +20,7 @@ class Teletype f where makeEffectF ''Teletype -teletypeToIO :: (SendIns IO (Fre es m), Monad m) => Fre (TeletypeI ': es) m ~> Fre es m +teletypeToIO :: (IO <: Fre es m, Monad m) => Fre (TeletypeI ': es) m ~> Fre es m teletypeToIO = interpret \case ReadTTY -> sendIns getLine WriteTTY msg -> sendIns $ putStrLn msg