diff --git a/README.md b/README.md index f6fdd43..85660dc 100644 --- a/README.md +++ b/README.md @@ -61,55 +61,92 @@ Make sure you read the [Necessary Language Extensions](https://github.com/isovector/polysemy#necessary-language-extensions) before trying these yourself! -Console effect: +Teletype effect: ```haskell {-# LANGUAGE TemplateHaskell #-} +{-# LANGUAGE LambdaCase, BlockArguments #-} +{-# LANGUAGE GADTs, FlexibleContexts, TypeOperators, DataKinds, PolyKinds #-} import Polysemy +import Polysemy.Input +import Polysemy.Output -data Console m a where - ReadTTY :: Console m String - WriteTTY :: String -> Console m () +data Teletype m a where + ReadTTY :: Teletype m String + WriteTTY :: String -> Teletype m () -makeSem ''Console +makeSem ''Teletype -runConsoleIO :: Member (Lift IO) r => Sem (Console ': r) a -> Sem r a -runConsoleIO = interpret $ \case +runTeletypeIO :: Member (Lift IO) r => Sem (Teletype ': r) a -> Sem r a +runTeletypeIO = interpret $ \case ReadTTY -> sendM getLine WriteTTY msg -> sendM $ putStrLn msg + +runTeletypePure :: [String] -> Sem (Teletype ': r) a -> Sem r ([String], a) +runTeletypePure i + = runFoldMapOutput pure -- For each WriteTTY in our program, consume an output by appending it to the list in a ([String], a) + . runListInput i -- Treat each element of our list of strings as a line of input + . reinterpret2 \case -- Reinterpret our effect in terms of Input and Output + ReadTTY -> maybe "" id <$> input + WriteTTY msg -> output msg + + +echo :: Member Teletype r => Sem r () +echo = do + i <- readTTY + case i of + "" -> pure () + _ -> writeTTY i >> echo + + +-- Let's pretend +echoPure :: [String] -> Sem '[] ([String], ()) +echoPure = flip runTeletypePure echo + +pureOutput :: [String] -> [String] +pureOutput = fst . run . echoPure + +-- Now let's do things +echoIO :: Sem '[Lift IO] () +echoIO = runTeletypeIO echo + +-- echo forever +main :: IO () +main = runM echoIO ``` Resource effect: ```haskell +{-# OPTIONS_GHC -fplugin=Polysemy.Plugin #-} {-# LANGUAGE TemplateHaskell #-} +{-# LANGUAGE LambdaCase, BlockArguments #-} +{-# LANGUAGE GADTs, FlexibleContexts, TypeOperators, DataKinds, PolyKinds, TypeApplications #-} -import qualified Control.Exception as X -import Polysemy +import Prelude hiding (throw, catch, bracket) +import Polysemy +import Polysemy.Input +import Polysemy.Output +import Polysemy.Error +import Polysemy.Resource -data Resource m a where - Bracket :: m a -> (a -> m ()) -> (a -> m b) -> Resource m b +-- Using Teletype effect from above -makeSem ''Resource +data CustomException = ThisException | ThatException deriving Show -runResource - :: forall r a - . Member (Lift IO) r - => (∀ x. Sem r x -> IO x) - -> Sem (Resource ': r) a - -> Sem r a -runResource finish = interpretH $ \case - Bracket alloc dealloc use -> do - a <- runT alloc - d <- bindT dealloc - u <- bindT use +program :: Members '[Resource, Teletype, Error CustomException] r => Sem r () +program = catch work $ \e -> writeTTY ("Caught " ++ show e) + where work = bracket (readTTY) (const $ writeTTY "exiting bracket") $ \input -> do + writeTTY "entering bracket" + case input of + "explode" -> throw ThisException + "weird stuff" -> writeTTY input >> throw ThatException + _ -> writeTTY input >> writeTTY "no exceptions" - let runIt :: Sem (Resource ': r) x -> IO x - runIt = finish .@ runResource - - sendM $ X.bracket (runIt a) (runIt . d) (runIt . u) +main :: IO (Either CustomException ()) +main = (runM .@ runResource .@@ runErrorInIO @CustomException) . runTeletypeIO $ program ``` Easy. @@ -172,4 +209,3 @@ You're going to want to stick all of this into your `package.yaml` file. - TypeOperators - TypeFamilies ``` -