diff --git a/ChangeLog.md b/ChangeLog.md --- a/ChangeLog.md +++ b/ChangeLog.md @@ -17,4 +17,8 @@ ## 0.3.0.1 (2020-10-14) -* Fixed some compilation issues with GHC 8.6 +* Fixed some compilation issues with GHC 8.6 + +## 0.3.0.2 (2020-10-21) + +* Added Control.Effect.Identity for pure effect interpretations. diff --git a/README.md b/README.md --- a/README.md +++ b/README.md @@ -41,6 +41,8 @@ ## Quick-Start Guide +Examples can be found in the [examples](/examples/Example) folder. The following sections give a quick overview of the most important features. + ### Defining Effects When defining effects or effect handlers, the module *Control.Effect.Machinery* provides everything we need: @@ -285,4 +287,3 @@ * `TemplateHaskell`-based code generation can yield code that does not compile if you go crazy with `m`-based parameters in higher-order effect methods (where `m` is the monad type parameter of the effect type class). In such cases, one has to write the necessary type class instances by hand. They are explained in the documentation of the module `Control.Effect.Machinery.TH`. * Effect type classes that are based on other effect type classes (like `RWS`) are possible, but cannot be used with the provided code generation infrastructure yet (not to be confused with writing an effect *handler* based on other effects, which is possible). * The performance should be `mtl`-like, but this has not been verified yet. -* The library needs some tests. diff --git a/effet.cabal b/effet.cabal --- a/effet.cabal +++ b/effet.cabal @@ -4,10 +4,10 @@ -- -- see: https://github.com/sol/hpack -- --- hash: cd058ddcf2f87961e00a8942c5ac3ebcda5ea45c798d1fdcd2b73cbe43c5f949 +-- hash: fd88a66a694dc0a14a3ea183cf0b921a1df3c88288a96e0410b5f548c9b3ff5d name: effet -version: 0.3.0.1 +version: 0.3.0.2 synopsis: An Effect System based on Type Classes description: Please see the README on GitHub at category: Control @@ -32,6 +32,7 @@ Control.Effect.Cont Control.Effect.Embed Control.Effect.Error + Control.Effect.Identity Control.Effect.Machinery Control.Effect.Machinery.Tagger Control.Effect.Machinery.TH @@ -60,6 +61,39 @@ build-depends: base >=4.7 && <5 , containers >=0.6.2.1 && <0.7 + , monad-control >=1.0.2.3 && <1.1 + , template-haskell >=2.14.0.0 && <3 + , transformers >=0.5.6.2 && <0.6 + , transformers-base >=0.4.5.2 && <0.5 + default-language: Haskell2010 + +test-suite examples + type: exitcode-stdio-1.0 + main-is: Main.hs + other-modules: + Example.Cont + Example.Embed + Example.Error + Example.FileSystem + Example.Logger + Example.Managed + Example.Map + Example.Reader + Example.Resource + Example.RWS + Example.State + Example.Writer + Hspec + Paths_effet + hs-source-dirs: + examples + default-extensions: AllowAmbiguousTypes ConstraintKinds DataKinds DerivingVia FlexibleContexts FlexibleInstances FunctionalDependencies GeneralizedNewtypeDeriving KindSignatures MultiParamTypeClasses PolyKinds RankNTypes ScopedTypeVariables TypeApplications TypeFamilies TypeOperators UndecidableInstances + ghc-options: -Wall + build-depends: + base >=4.7 && <5 + , containers >=0.6.2.1 && <0.7 + , effet + , hspec >=2.6.0 && <3 , monad-control >=1.0.2.3 && <1.1 , template-haskell >=2.14.0.0 && <3 , transformers >=0.5.6.2 && <0.6 diff --git a/examples/Example/Cont.hs b/examples/Example/Cont.hs new file mode 100644 --- /dev/null +++ b/examples/Example/Cont.hs @@ -0,0 +1,36 @@ +-- | Examples of the continuation effect. +module Example.Cont where + +-- hspec +import Test.Hspec (Spec, it, shouldBe) + +-- effet +import Control.Effect.Cont +import Control.Effect.Identity + +import Example.Logger + +--- Example Programs ----------------------------------------------------------- + +fiveTimesCont :: (Cont m, Logger m) => m () +fiveTimesCont = do + logStr "x" + (k, num) <- callCC $ \k -> let f x = k (f, x) + in pure (f, 0::Int) + logStr "y" + logStr "z" + if num < 5 + then k (num + 1) >> pure () + else logStr $ show num + +--- Test Cases ----------------------------------------------------------------- + +spec :: Spec +spec = do + it "evaluates fiveTimesCont" $ + ( runIdentity -- result: ((), [String]) + . runCollectLogger -- result: Monad m => m ((), [String]) + . evalCont -- effects: Logger + $ fiveTimesCont -- effects: Cont, Logger + ) `shouldBe` + ((), ["5","z","y","z","y","z","y","z","y","z","y","z","y","x"]) diff --git a/examples/Example/Embed.hs b/examples/Example/Embed.hs new file mode 100644 --- /dev/null +++ b/examples/Example/Embed.hs @@ -0,0 +1,87 @@ +-- | Examples of the embed effect. +module Example.Embed where + +-- base +import Control.Monad (guard) +import Data.Maybe (listToMaybe, maybeToList) +import Prelude hiding (print) + +-- hspec +import Test.Hspec (Spec, it, shouldBe) + +-- effet +import Control.Effect.Embed +import Control.Effect.Reader + +import Hspec (print, shouldPrint) + +--- Example Programs ----------------------------------------------------------- + +-- | Find shared numbers of two reader-based lists using the list monad. +intersect :: (Reader' "xs" [Int] m, Reader' "ys" [Int] m, Embed [] m) => m Int +intersect = do + xs <- ask' @"xs" + ys <- ask' @"ys" + embed $ do + x <- xs + y <- ys + guard $ x == y + pure x + +-- | Divide two numbers using the maybe monad. +divide :: Embed Maybe m => Maybe Int -> Maybe Int -> m Int +divide mx my = embed $ do + x <- mx + y <- my + guard $ y /= 0 + pure $ x `div` y + +-- | Performs multiple divisions. +divisions :: Embed [] m => Maybe Int -> m Int +divisions divisor = do + a <- runEmbed maybeToList $ divide (Just 3) (Just 1) + b <- runEmbed maybeToList $ divide (Just 2) divisor + c <- runEmbed maybeToList $ divide (Just 5) divisor + d <- runEmbed maybeToList $ divide (Just 9) (Just 4) + embed [a,b,c,d] + +-- | Uses embed instead of liftIO to print texts with prefix and suffix (reader). +simulateLiftIO :: (Embed IO m, Reader String m) => String -> m () +simulateLiftIO prefix = do + suffix <- ask + embed $ do + print $ prefix ++ "Hello" ++ suffix + print $ prefix ++ "World" ++ suffix + +--- Test Cases ----------------------------------------------------------------- + +spec :: Spec +spec = do + it "evaluates intersect with []" $ + ( runReader' @"ys" [2,3,4] -- effects: Embed [], result: [Int] + . runReader' @"xs" [1,2,3] -- effects: Reader' "ys" [Int], Embed [] + $ intersect ) -- effects: Reader' "xs" [Int], Reader' "ys" [Int], Embed [] + `shouldBe` [2,3] + it "evaluates intersect with Maybe" $ + ( runEmbed listToMaybe -- effects: Embed Maybe, result: Maybe Int + . runReader' @"ys" [2,3,4] -- effects: Embed [] + . runReader' @"xs" [1,2,3] -- effects: Reader' "ys" [Int], Embed [] + $ intersect ) -- effects: Reader' "xs" [Int], Reader' "ys" [Int], Embed [] + `shouldBe` Just 2 + it "evaluates division" $ + ( divide (Just 10) (Just 3) ) -- effects: Embed Maybe, result: Maybe Int + `shouldBe` Just 3 + it "evaluates division by zero" $ + ( divide (Just 2) (Just 0) ) -- effects: Embed Maybe, result: Maybe Int + `shouldBe` Nothing + it "evaluates divisions" $ + ( divisions (Just 2) ) -- effects: Embed [], result: [Int] + `shouldBe` [3,1,2,2] + it "evaluates divisions by zero" $ + ( divisions Nothing ) -- effects: Embed Maybe, result: Maybe [Int] + `shouldBe` [] + it "evaluates simulateLiftIO" $ + ( runReader " [S]" -- effects: Embed IO, result: IO () + $ simulateLiftIO "[P] " ) -- effects: Embed IO, Reader String + `shouldPrint` + "\"[P] Hello [S]\"\n\"[P] World [S]\"\n" diff --git a/examples/Example/Error.hs b/examples/Example/Error.hs new file mode 100644 --- /dev/null +++ b/examples/Example/Error.hs @@ -0,0 +1,85 @@ +-- | Examples of the error effect. +module Example.Error where + +-- base +import Control.Monad.IO.Class (MonadIO, liftIO) +import Prelude hiding (print) + +-- hspec +import Test.Hspec (Spec, it, shouldBe) + +-- effet +import Control.Effect.Error +import Control.Effect.Identity +import Control.Effect.Reader + +import Hspec (print, shouldPrint) + +--- Example Programs ----------------------------------------------------------- + +data DivideByZero = DivideByZero + deriving (Eq, Show) + +-- | Divides two numbers, may yield an error when dividing by zero. +divide :: Error DivideByZero m => Int -> Int -> m Int +divide _ 0 = throwError DivideByZero +divide x y = pure $ x `div` y + +-- | Divides two numbers and returns a default value in case of zero division. +catchDivide :: Error DivideByZero m => Int -> Int -> m Int +catchDivide x y = + catchError + ( divide x y ) + ( \_ -> pure 1337 ) + +-- | Divides two numbers found in the readers, catches the division by zero +-- error and prints a String describing the result. +divideByReader :: ( Error DivideByZero m + , MonadIO m + , Reader' "numerator" Int m + , Reader' "divisor" Int m ) + => m () +divideByReader = do + n <- ask' @"numerator" + d <- ask' @"divisor" + catchError + ( do r <- divide n d + liftIO . print $ "Result: " ++ show r ) + ( \e -> + liftIO . print $ "Error: " ++ show e ) + +--- Test Cases ----------------------------------------------------------------- + +spec :: Spec +spec = do + it "divides normally" $ + ( runIdentity -- result: Either DivideByZero Int + . runError -- result: Monad m => m (Either DivideByZero Int) + $ divide 8 3 ) -- effects: Error DivideByZero + `shouldBe` Right 2 + it "divides by zero" $ + ( runIdentity -- result: Either DivideByZero Int + . runError -- result: Monad m => m (Either DivideByZero Int) + $ divide 5 0 ) -- effects: Error DivideByZero + `shouldBe` Left DivideByZero + it "catches division by zero" $ + ( runIdentity -- result: Either DivideByZero Int + . runError -- result: Monad m => m (Either DivideByZero Int) + $ catchDivide 5 0 ) -- effects: Error DivideByZero + `shouldBe` Right 1337 + it "catches normally" $ + ( runReader' @"divisor" 3 -- result: MonadIO m => m (Either DivideByZero ()), + -- unified with IO (Either DivideByZero ()) + . runReader' @"numerator" 17 -- effects: Reader' "divisor", MonadIO + . runError -- effects: Reader' "numerator", Reader' "divisor", MonadIO + $ divideByReader ) -- effects: Error DivideByZero, Reader' "numerator", + -- Reader' "divisor", MonadIO + `shouldPrint` "\"Result: 5\"\n" + it "catches division by zero" $ + ( runReader' @"divisor" 0 -- result: MonadIO m => m (Either DivideByZero ()), + -- unified with IO (Either DivideByZero ()) + . runReader' @"numerator" 17 -- effects: Reader' "divisor", MonadIO + . runError -- effects: Reader' "numerator", Reader' "divisor", MonadIO + $ divideByReader ) -- effects: Error DivideByZero, Reader' "numerator", + -- Reader' "divisor", MonadIO + `shouldPrint` "\"Error: DivideByZero\"\n" diff --git a/examples/Example/FileSystem.hs b/examples/Example/FileSystem.hs new file mode 100644 --- /dev/null +++ b/examples/Example/FileSystem.hs @@ -0,0 +1,129 @@ +{-# LANGUAGE TemplateHaskell #-} +-- | Example of a custom effect for file systems access. +module Example.FileSystem where + +-- base +import Data.Coerce (coerce) +import Data.Maybe (fromMaybe) +import Prelude hiding (lookup, readFile, writeFile) +import qualified System.IO as IO + +-- hspec +import Test.Hspec (Spec, it, shouldBe) + +-- effet +import Control.Effect.Identity +import Control.Effect.Machinery +import Control.Effect.Map +import Control.Effect.Map.Strict + +import Example.Logger +import Hspec (shouldPrint) + +--- Custom Effects ------------------------------------------------------------- + +-- | An effect for representing file system access. +class Monad m => FileSystem m where + readFile :: FilePath -> m String + writeFile :: FilePath -> String -> m () + +makeEffect ''FileSystem + +--- Effect Interpretations ----------------------------------------------------- + +-- | An effect handler for 'FileSystem' which touches the actual file system. +newtype LocalFS m a = + LocalFS { runLocalFS :: m a } + deriving (Applicative, Functor, Monad, MonadIO) + deriving (MonadTrans, MonadTransControl) via IdentityT + deriving (MonadBase b, MonadBaseControl b) + +instance MonadIO m => FileSystem (LocalFS m) where + readFile path = liftIO $ IO.readFile path + writeFile path txt = liftIO $ IO.writeFile path txt + +runLocalFileSystem :: (FileSystem `Via` LocalFS) m a -> m a +runLocalFileSystem = coerce + +-- | An effect handler for 'FileSystem' which provides a virtual file system. +newtype VirtualFS m a = + VirtualFS { runVirtualFS :: m a } + deriving (Applicative, Functor, Monad, MonadIO) + deriving (MonadTrans, MonadTransControl) via IdentityT + deriving (MonadBase b, MonadBaseControl b) + +instance Map FilePath String m => FileSystem (VirtualFS m) where + readFile path = VirtualFS $ fromMaybe "" <$> lookup path + writeFile path txt = VirtualFS $ insert path txt + +runVirtualFileSystem :: (FileSystem `Via` VirtualFS) m a -> m a +runVirtualFileSystem = coerce + +-- | An effect handler for 'FileSystem' which intercepts the access to files +-- and logs the actions using the 'Logger' effect. +newtype Interceptor m a = + Interceptor { unInterceptor :: m a } + deriving (Applicative, Functor, Monad, MonadIO) + deriving (MonadTrans, MonadTransControl) via IdentityT + deriving (MonadBase b, MonadBaseControl b) + +instance (FileSystem m, Logger m) => FileSystem (Interceptor m) where + readFile path = Interceptor $ + logStr ("READ: " ++ path) >> readFile path + writeFile path txt = Interceptor $ + logStr ("WRITE: " ++ path ++ " [" ++ txt ++ "]") >> writeFile path txt + +runInterceptor :: (FileSystem `Via` Interceptor) m a -> m a +runInterceptor = coerce + +--- Example Programs ----------------------------------------------------------- + +-- | Simple program which writes a file and reads it afterwards and returns the +-- old and new file content. +writeRead :: FileSystem m => FilePath -> String -> m (String, String) +writeRead path txt = do + old <- readFile path + writeFile path txt + new <- readFile path + pure (old, new) + +-- | Appends a text to a file given by a specific file path, and returns the old +-- and new lengths of the file. +append :: FileSystem m => FilePath -> String -> m (Int, Int) +append path txt = do + content <- readFile path + let size = length content + seq size $ writeFile path (content ++ txt) + pure (size, size + length txt) + +--- Test Cases ----------------------------------------------------------------- + +spec :: Spec +spec = do + it "evaluates writeRead virtually" $ + ( runIdentity -- result: (String, String) + . runMap -- result: Monad m => m (String, String) + . runVirtualFileSystem -- effects: Map FilePath String + $ writeRead "tmp" "hello" -- effects: FileSystem + ) `shouldBe` ("", "hello") + it "evaluates append virtually" $ + ( runIdentity -- result: (Int, Int) + . runMap -- result: Monad m => m (Int, Int) + . runVirtualFileSystem -- effects: Map FilePath String + $ append "tmp" "hello" -- effects: FileSystem + ) `shouldBe` (0, 5) + it "intercepts append by printing" $ + ( runPrintLogger -- result: MonadIO m => m (), unified with IO () + . runMap -- effects: Logger + . runVirtualFileSystem -- effects: Map FilePath String, Logger + . runInterceptor -- effects: FileSystem, Logger + $ append "tmp" "hello" -- effects: FileSystem + ) `shouldPrint` "\"READ: tmp\"\n\"WRITE: tmp [hello]\"\n" + it "intercepts append by collecting" $ + ( runIdentity -- result: ((Int, Int), [String]) + . runCollectLogger -- result: Monad m => m ((Int, Int), [String]) + . runMap -- effects: Logger + . runVirtualFileSystem -- effects: Map FilePath String, Logger + . runInterceptor -- effects: FileSystem, Logger + $ append "tmp" "hello" -- effects: FileSystem + ) `shouldBe` ((0, 5), ["WRITE: tmp [hello]", "READ: tmp"]) diff --git a/examples/Example/Logger.hs b/examples/Example/Logger.hs new file mode 100644 --- /dev/null +++ b/examples/Example/Logger.hs @@ -0,0 +1,113 @@ +{-# LANGUAGE TemplateHaskell #-} +-- | Example of a custom effect for logging. +module Example.Logger where + +-- base +import Data.Coerce (coerce) +import Prelude hiding (print) + +-- hspec +import Test.Hspec (Spec, it, shouldBe) + +-- effet +import Control.Effect.Identity +import Control.Effect.Machinery +import Control.Effect.Reader + +-- transformers +import qualified Control.Monad.Trans.State.Strict as S + +import Hspec (print, shouldPrint) + +--- Custom Effects ------------------------------------------------------------- + +-- | An effect for logging. +class Monad m => Logger m where + logStr :: String -> m () + +makeEffect ''Logger + +--- Effect Interpretations ----------------------------------------------------- + +-- | An effect handler for 'Logger' which prints the logged strings. +newtype PrintLogger m a = + PrintLogger { unPrintLogger :: m a } + deriving (Applicative, Functor, Monad, MonadIO) + deriving (MonadTrans, MonadTransControl) via IdentityT + deriving (MonadBase b, MonadBaseControl b) + +instance MonadIO m => Logger (PrintLogger m) where + logStr = print + +runPrintLogger :: (Logger `Via` PrintLogger) m a -> m a +runPrintLogger = coerce + +-- | An effect handler for 'Logger' which collects the logged strings in reverse +-- order (newest comes first). +newtype CollectLogger m a = + CollectLogger { unCollectLogger :: S.StateT [String] m a } + deriving (Applicative, Functor, Monad, MonadIO) + deriving (MonadTrans, MonadTransControl) + deriving (MonadBase b, MonadBaseControl b) + +instance Monad m => Logger (CollectLogger m) where + logStr txt = CollectLogger $ S.modify (txt :) + +runCollectLogger :: (Logger `Via` CollectLogger) m a -> m (a, [String]) +runCollectLogger = flip S.runStateT [] . coerce + +-- | An effect handler for 'Logger' which suppresses logging. +newtype NoLogger m a = + NoLogger { unNoLogger :: m a } + deriving (Applicative, Functor, Monad, MonadIO) + deriving (MonadTrans, MonadTransControl) via IdentityT + deriving (MonadBase b, MonadBaseControl b) + +instance Monad m => Logger (NoLogger m) where + logStr _ = pure () + +runNoLogger :: (Logger `Via` NoLogger) m a -> m a +runNoLogger = coerce + +--- Example Programs ----------------------------------------------------------- + +-- | Simple program which logs some steps. +logging :: (Logger m, MonadIO m) => m () +logging = do + print "A" + logStr $ "Done A" + print "B" + logStr $ "Done B" + print "C" + logStr $ "Done C" + +-- | Logs and returns the sum of a number and the reader value. +adding :: (Reader Int m, Logger m) => Int -> m Int +adding offset = do + num <- ask + logStr $ "Asked: " ++ show num + let result = offset + num + logStr $ "Sum: " ++ show result + pure result + +--- Test Cases ----------------------------------------------------------------- + +spec :: Spec +spec = do + it "evaluates logging by suppression" $ + ( runNoLogger -- result: MonadIO m => m (), unified with IO () + $ logging -- effects: Logger, MonadIO + ) `shouldPrint` + "\"A\"\n\"B\"\n\"C\"\n" + it "evaluates logging by printing" $ + ( runPrintLogger -- result: MonadIO m => m (), unified with IO () + $ logging -- effects: Logger, MonadIO + ) `shouldPrint` + "\"A\"\n\"Done A\"\n\"B\"\n\"Done B\"\n\"C\"\n\"Done C\"\n" + it "evaluates logging by collecting" $ + ( runIdentity -- result: (Int, [String]) + . runCollectLogger -- result: Monad m => m (Int, [String]) + . runReader 1327 -- effects: Logger + $ adding 10 -- effects: Reader Int, Logger + ) `shouldBe` + (1337, ["Sum: 1337", "Asked: 1327"]) diff --git a/examples/Example/Managed.hs b/examples/Example/Managed.hs new file mode 100644 --- /dev/null +++ b/examples/Example/Managed.hs @@ -0,0 +1,79 @@ +-- | Examples of the managed effect. +module Example.Managed where + +-- base +import Control.Monad.IO.Class (MonadIO) +import Prelude hiding (print) + +-- hspec +import Test.Hspec (Spec, it) + +-- effet +import Control.Effect.Error +import Control.Effect.Managed + +import Hspec (print, shouldPrint) + +--- Example Programs ----------------------------------------------------------- + +-- | Type used here as virtual handle. +newtype Handle = Handle { nameOf :: String } + +-- | Gets a managed virtual handle specified by a name. +getHandle :: (Managed m, MonadIO m) => String -> m Handle +getHandle name = manage + ( print ("Alloc " ++ name) >> pure (Handle name) ) + ( \handle -> print $ "Free " ++ nameOf handle ) + +-- | Simple program that makes use of two handles. Handles are destroyed +-- automatically at the end of the program. +useHandles :: (Managed m, MonadIO m) => m () +useHandles = do + a <- getHandle "A" + b <- getHandle "B" + print $ "Use " ++ nameOf a + print $ "Use " ++ nameOf b + +-- | Allocates some handlers, then throws an error. +throwCheck :: (Error String m, Managed m, MonadIO m) => m () +throwCheck = do + a <- getHandle "A" + b <- getHandle "B" + print $ "Use " ++ nameOf a + _ <- throwError "Some error" + print $ "Use " ++ nameOf b + +--- Test Cases ----------------------------------------------------------------- + +spec :: Spec +spec = do + it "manages a handle" $ + ( runManaged -- result: (MonadBaseControl IO m, MonadIO m) => m (), + -- unified with IO () + $ getHandle "X" ) -- effects: Managed, MonadIO + `shouldPrint` + "\"Alloc X\"\n\"Free X\"\n" + it "manages multiple handles" $ + ( runManaged -- result: (MonadBaseControl IO m, MonadIO m) => m (), + -- unified with IO () + $ useHandles ) -- effects: Managed, MonadIO + `shouldPrint` + ( "\"Alloc A\"\n" + ++ "\"Alloc B\"\n" + ++ "\"Use A\"\n" + ++ "\"Use B\"\n" + ++ "\"Free B\"\n" + ++ "\"Free A\"\n" + ) + it "manages multiple handles with an error" $ + ( runManaged -- result: (MonadBaseControl IO m, MonadIO m) => m (Either String ()), + -- unified with IO (Either String ()) + . runError -- effects: Managed, MonadIO + $ throwCheck ) -- effects: Error String, Managed, MonadIO + `shouldPrint` + ( "\"Alloc A\"\n" + ++ "\"Alloc B\"\n" + ++ "\"Use A\"\n" + ++ "\"Free B\"\n" + ++ "\"Free A\"\n" + ) diff --git a/examples/Example/Map.hs b/examples/Example/Map.hs new file mode 100644 --- /dev/null +++ b/examples/Example/Map.hs @@ -0,0 +1,71 @@ +-- | Examples of the map effect. +module Example.Map where + +-- base +import Prelude hiding (lookup) + +-- hspec +import Test.Hspec (Spec, it, shouldBe) + +-- effet +import Control.Effect.Identity +import Control.Effect.Map +import qualified Control.Effect.Map.Lazy as L +import qualified Control.Effect.Map.Strict as S + +--- Example Programs ----------------------------------------------------------- + +-- | Performs some inserts on the map and checks if their removal works. +removal :: Map Int String m => m Bool +removal = do + insert 1 "Hello" + beforeClear <- exists 1 + clear + afterClear <- exists 1 + insert 2 "World" + beforeDelete <- exists 2 + delete 2 + afterDelete <- exists 2 + pure $ beforeClear && not afterClear && beforeDelete && not afterDelete + +-- | Performs some modifications on the map and checks the changes. +modification :: Map Int String m => m (Maybe String, Maybe String, Maybe String) +modification = do + insert 1 "Hello" + modify "" (++ " World") 1 + modify "N/A" (++ " here?") 2 + h <- lookup 1 + n <- lookup 2 + x <- lookup 3 + pure (h, n, x) + +multiMaps :: (Map' "a" Int String m, Map' "b" String Int m) => m (Maybe String) +multiMaps = do + insert' @"a" 1 "Hello" + insert' @"b" "World" 1 + maybeOne <- lookup' @"b" "World" + case maybeOne of + Nothing -> pure Nothing + Just one -> lookup' @"a" one + +--- Test Cases ----------------------------------------------------------------- + +spec :: Spec +spec = do + it "evaluates removal" $ + ( runIdentity -- result: Bool + . L.runMap -- result: Monad m => m Bool + $ removal ) -- effects: Map Int String + `shouldBe` True + it "evaluates modification" $ + ( runIdentity -- result: (Maybe String, Maybe String, Maybe String) + . S.runMap -- result: Monad m => m (Maybe String, Maybe String, Maybe String) + $ modification ) -- effects: Map Int String + `shouldBe` + (Just "Hello World", Just "N/A here?", Nothing) + it "evaluates multiple maps" $ + ( runIdentity -- result: Maybe String + . L.runMap' @"b" -- result: Monad m => m (Maybe String) + . S.runMap' @"a" -- effects: Map' "b" String Int + $ multiMaps ) -- effects: Map' "a" Int String, Map' "b" String Int + `shouldBe` Just "Hello" diff --git a/examples/Example/RWS.hs b/examples/Example/RWS.hs new file mode 100644 --- /dev/null +++ b/examples/Example/RWS.hs @@ -0,0 +1,52 @@ +-- | Examples of the RWS effect. +module Example.RWS where + +-- base +import Data.Monoid (Sum(Sum)) + +-- hspec +import Test.Hspec (Spec, it, shouldBe) + +-- effet +import Control.Effect.Identity +import Control.Effect.Reader +import Control.Effect.RWS +import Control.Effect.State +import qualified Control.Effect.State.Lazy as L +import qualified Control.Effect.Writer.Strict as S +import qualified Control.Effect.RWS.Lazy as L + +import Example.Reader (triple) +import Example.State (increment) +import Example.Writer (sumWriter) + +--- Example Programs ----------------------------------------------------------- + +-- | Combine reader, writer and state examples from the other test cases. +combineRWS :: RWS Int (Sum Int) Int m => m (Int, Int, Int) +combineRWS = do + r <- triple + w <- sumWriter + increment + s <- get + pure (r, w, s) + +--- Test Cases ----------------------------------------------------------------- + +spec :: Spec +spec = do + it "combines reader/write/state test cases" $ + ( runIdentity -- result: (Sum Int, Int, (Int, Int, Int)) + . L.runRWS 20 5 -- result: Monad m => m (Sum Int, Int, (Int, Int, Int)) + $ combineRWS ) -- effects: RWS Int (Sum Int) Int + `shouldBe` + (Sum 18, 6, (60, 13, 6)) + it "separates reader/write/state components" $ + ( runIdentity -- result: (Int, (Sum Int, (Int, Int, Int))) + . L.runState 3 -- result: Monad m => m (Int, (Sum Int, (Int, Int, Int))) + . S.runWriter -- effects: State Int + . runReader 15 -- effects: Writer (Sum Int), State Int + . runSeparatedRWS -- effects: Reader Int, Writer (Sum Int), State Int + $ combineRWS ) -- effects: RWS Int (Sum Int) Int + `shouldBe` + (4, (Sum 18, (45, 13, 4))) diff --git a/examples/Example/Reader.hs b/examples/Example/Reader.hs new file mode 100644 --- /dev/null +++ b/examples/Example/Reader.hs @@ -0,0 +1,59 @@ +-- | Examples of the reader effect. +module Example.Reader where + +-- base +import Control.Monad.IO.Class (MonadIO) +import Prelude hiding (print) + +-- hspec +import Test.Hspec (Spec, it, shouldBe) + +-- effet +import Control.Effect.Identity +import Control.Effect.Reader + +import Hspec (print, shouldPrint) + +--- Example Programs ----------------------------------------------------------- + +-- | Returns the triple of the number in the reader. +triple :: Reader Int m => m Int +triple = do + single <- ask + double <- asks (*2) + pure $ single + double + +-- | Prints the triple and sixfold of the number in the reader. +printTripleSix :: (MonadIO m, Reader Int m) => m () +printTripleSix = do + t <- triple + s <- local (*2) triple + print t + print s + +-- | Prints the double of reader "bar" and the triple of reader "foo". +printFooBar :: (MonadIO m, Reader' "bar" Int m, Reader' "foo" Int m) => m () +printFooBar = + local' @"bar" (*2) $ + local' @"foo" (*3) $ do + ask' @"bar" >>= print + ask' @"foo" >>= print + +--- Test Cases ----------------------------------------------------------------- + +spec :: Spec +spec = do + it "evaluates triple" $ + ( runIdentity -- result: Int + . runReader 22 -- result: Monad m => m Int + $ triple ) -- effects: Reader Int + `shouldBe` 66 + it "evaluates printTripleSix" $ + runReader 10 -- result: MonadIO m => m (), unified with IO () + printTripleSix -- effects: MonadIO, Reader Int + `shouldPrint` "30\n60\n" + it "evaluates printFooBar" $ + ( runReader' @"bar" 20 -- result: MonadIO m => m (), unified with IO () + . runReader' @"foo" 50 -- effects: MonadIO, Reader' "bar" Int + $ printFooBar -- effects: MonadIO, Reader' "bar" Int, Reader' "foo" Int + ) `shouldPrint` "40\n150\n" diff --git a/examples/Example/Resource.hs b/examples/Example/Resource.hs new file mode 100644 --- /dev/null +++ b/examples/Example/Resource.hs @@ -0,0 +1,71 @@ +-- | Examples of the resource effect. +module Example.Resource where + +-- base +import qualified Control.Exception as E +import Control.Monad.IO.Class (MonadIO) +import Prelude hiding (print) + +-- hspec +import Test.Hspec (Spec, it) + +-- effet +import Control.Effect.Error +import Control.Effect.Resource + +import Hspec (print, shouldPrint) + +--- Example Programs ----------------------------------------------------------- + +-- | Type used here as virtual handle. +newtype Handle = Handle { nameOf :: String } + +-- | Simple bracket with print outputs. +aBracket :: (MonadIO m, Resource m) => String -> m () +aBracket name = do + bracket + ( print ("Alloc " ++ name) >> pure (Handle name) ) + ( \handle -> print $ "Free " ++ nameOf handle ) + ( \handle -> print $ "Use " ++ nameOf handle ) + +-- | Simple bracket with print outputs. +aBracketOnError :: (MonadIO m, Resource m) => String -> m () +aBracketOnError name = do + bracketOnError + ( print ("Alloc " ++ name) >> pure (Handle name) ) + ( \handle -> print $ "Free " ++ nameOf handle ) + ( \handle -> print $ "Use " ++ nameOf handle ) + +-- | Bracket where the usage function throws an ArrayException. +errorBracket :: (Error String m, MonadIO m, Resource m) => String -> m () +errorBracket name = do + bracket + ( print ("Alloc " ++ name) >> pure (Handle name) ) + ( \handle -> print $ "Free " ++ nameOf handle ) + ( \handle -> E.throw (E.UndefinedElement $ nameOf handle ) ) + +--- Test Cases ----------------------------------------------------------------- + +spec :: Spec +spec = do + it "evaluates a bracket" $ + ( runResourceIO -- result: (MonadBaseControl IO m, MonadIO m) => m (), + -- unified with IO () + $ aBracket "X" ) -- effects: MonadIO, Resource + `shouldPrint` + "\"Alloc X\"\n\"Use X\"\n\"Free X\"\n" + it "evaluates a bracket without freeing" $ + ( runResourceIO -- result: (MonadBaseControl IO m, MonadIO m) => m (), + -- unified with IO () + $ aBracketOnError "X" ) -- effects: MonadIO, Resource + `shouldPrint` + "\"Alloc X\"\n\"Use X\"\n" + it "evaluates a bracket with an error" $ + ( runResourceIO -- result: (MonadBaseControl IO m, MonadIO m) => m (Either String ()), + -- unified with IO (Either String ()) + . runError -- effects: MonadIO, Resource + $ errorBracket "X" ) -- effects: Error String, MonadIO, Resource + `E.catch` + ( \(_ :: E.ArrayException) -> pure (Left "Intended error") ) + `shouldPrint` + "\"Alloc X\"\n\"Free X\"\n" diff --git a/examples/Example/State.hs b/examples/Example/State.hs new file mode 100644 --- /dev/null +++ b/examples/Example/State.hs @@ -0,0 +1,66 @@ +-- | Examples of the state effect. +module Example.State where + +-- hspec +import Test.Hspec (Spec, it, shouldBe) + +-- effet +import Control.Effect.Identity +import Control.Effect.State +import qualified Control.Effect.State.Lazy as L +import qualified Control.Effect.State.Strict as S + +--- Example Programs ----------------------------------------------------------- + +-- | Increments the state. +increment :: (Num n, State n m) => m () +increment = modify (+1) + +-- | Increments the state tagged "s" by 3 and adds up the old and new values. +incrementWithResult :: State' "s" Int m => m String +incrementWithResult = do + before <- get' @"s" + modify' @"s" (+3) + after <- get' @"s" + pure . show $ before + after + +-- | Increments two elements in a tuple. +incrementBoth :: (Num n1, Num n2, State (n1,n2) m) => m () +incrementBoth = modify (\(x,y) -> (x+1, y+1)) + +-- | Increments the state tagged "foo" by 1, +-- increments the state tagged "bar" by 2, +-- then adds up the two states. +twoStates :: (State' "foo" Int m, State' "bar" Int m) => m Int +twoStates = do + tagState' @"foo" $ increment + tagState' @"bar" $ increment >> increment + foo <- get' @"foo" + bar <- get' @"bar" + pure $ foo + bar + +--- Test Cases ----------------------------------------------------------------- + +spec :: Spec +spec = do + it "evaluates increment" $ + ( runIdentity -- result: Int + . L.execState 5 -- result: (Num n, Monad m) => m n + $ increment -- effects: Num n => State n + ) `shouldBe` (6::Int) + it "evaluates incrementWithResult" $ + ( runIdentity -- result: (Int, String) + . S.runState' @"s" 5 -- result: Monad m => m (Int, String) + $ incrementWithResult -- effects: State' "s" Int + ) `shouldBe` (8, "13") + it "evaluates incrementBoth" $ + ( runIdentity -- result: (Int, Int) + . L.execState (1,2) -- result: (Num n1, Num n2, Monad m) => m (n1, n2) + $ incrementBoth -- effects: (Num n1, Num n2) => State (n1, n2) + ) `shouldBe` (2::Int, 3::Int) + it "evaluates twoStates" $ + ( runIdentity -- result: (Int, (Int, Int)) + . L.runState' @"foo" 3 -- result: Monad m => m (Int, (Int, Int)) + . S.runState' @"bar" 5 -- effects: State' "foo" Int + $ twoStates -- effects: State' "foo" Int, State' "bar" Int + ) `shouldBe` (4, (7, 11)) diff --git a/examples/Example/Writer.hs b/examples/Example/Writer.hs new file mode 100644 --- /dev/null +++ b/examples/Example/Writer.hs @@ -0,0 +1,63 @@ +-- | Examples of the writer effect. +module Example.Writer where + +-- base +import Data.Monoid (Sum(Sum), getSum) + +-- hspec +import Test.Hspec (Spec, it, shouldBe) + +-- effet +import Control.Effect.Identity +import Control.Effect.State +import Control.Effect.Writer +import qualified Control.Effect.State.Lazy as L +import qualified Control.Effect.Writer.Lazy as L +import qualified Control.Effect.Writer.Strict as S + +--- Example Programs ----------------------------------------------------------- + +-- | Write something in a sub-action, capture it and tell something again. +sumWriter :: Writer (Sum Int) m => m Int +sumWriter = do + (w,a) <- listen $ do tell 5 + pure 8 + tell w + tell a + pure $ getSum (w + a) + +-- | Combines the state and writer effect. +stateWriter :: (State Int m, Writer [Int] m) => m Int +stateWriter = do + tell [1,2,3] + num <- get + tell [num, num + 1, num + 2] + pure num + +-- | Censors (modifies) the output of sumWriter. +censorWriter :: Writer (Sum Int) m => m Int +censorWriter = censor (fmap (+1)) sumWriter + +--- Test Cases ----------------------------------------------------------------- + +spec :: Spec +spec = do + it "listens to sub-action writings" $ + ( runIdentity -- result: (Sum Int, Int) + . S.runWriter -- result: Monad m => m (Sum Int, Int) + $ sumWriter ) -- effects: Writer (Sum Int) + `shouldBe` + (Sum 18, 13) + it "combines state and writer" $ + ( runIdentity -- result: ([Int], Int) + . L.runWriter -- result: Monad m => m ([Int], Int) + . L.execState 4 -- effects: Writer [Int] + $ stateWriter ) -- effects: State Int, Writer [Int] + `shouldBe` + ([1,2,3,4,5,6], 4) + it "censors/modifies output" $ + ( runIdentity -- result: (Sum Int, Int) + . L.runWriter -- result: Monad m => m (Sum Int, Int) + $ censorWriter ) -- effects: Writer (Sum Int) + `shouldBe` + (Sum 19, 13) diff --git a/examples/Hspec.hs b/examples/Hspec.hs new file mode 100644 --- /dev/null +++ b/examples/Hspec.hs @@ -0,0 +1,25 @@ +module Hspec (print, shouldPrint) where + +-- base +import Control.Exception (bracket) +import Control.Monad.IO.Class (MonadIO, liftIO) +import Data.IORef (IORef, modifyIORef, newIORef, readIORef, writeIORef) +import Prelude hiding (print) +import System.IO.Unsafe (unsafePerformIO) + +-- hspec +import Test.Hspec (shouldBe) + +stdoutMock :: IORef String +stdoutMock = unsafePerformIO (newIORef "") + +print :: (MonadIO m, Show a) => a -> m () +print txt = liftIO $ + modifyIORef stdoutMock (++ show txt ++ "\n") + +shouldPrint :: IO a -> String -> IO () +shouldPrint action expectedOutput = + bracket + ( action ) + ( \_ -> writeIORef stdoutMock "" ) + ( \_ -> readIORef stdoutMock >>= (`shouldBe` expectedOutput) ) diff --git a/examples/Main.hs b/examples/Main.hs new file mode 100644 --- /dev/null +++ b/examples/Main.hs @@ -0,0 +1,35 @@ +module Main where + +-- hspec +import Test.Hspec (Spec, describe, hspec) + +import qualified Example.Cont +import qualified Example.Embed +import qualified Example.Error +import qualified Example.FileSystem +import qualified Example.Logger +import qualified Example.Managed +import qualified Example.Map +import qualified Example.Reader +import qualified Example.Resource +import qualified Example.RWS +import qualified Example.State +import qualified Example.Writer + +spec :: Spec +spec = do + describe "Cont" Example.Cont.spec + describe "Embed" Example.Embed.spec + describe "Error" Example.Error.spec + describe "FileSystem" Example.FileSystem.spec + describe "Logger" Example.Logger.spec + describe "Managed" Example.Managed.spec + describe "Map" Example.Map.spec + describe "Reader" Example.Reader.spec + describe "Resource" Example.Resource.spec + describe "RWS" Example.RWS.spec + describe "State" Example.State.spec + describe "Writer" Example.Writer.spec + +main :: IO () +main = hspec spec diff --git a/src/Control/Effect/Identity.hs b/src/Control/Effect/Identity.hs new file mode 100644 --- /dev/null +++ b/src/Control/Effect/Identity.hs @@ -0,0 +1,27 @@ +----------------------------------------------------------------------------- +-- | +-- Module : Control.Effect.Identity +-- Copyright : (c) Michael Szvetits, 2020 +-- License : BSD3 (see the file LICENSE) +-- Maintainer : typedbyte@qualified.name +-- Stability : stable +-- Portability : portable +-- +-- This module provides the function 'runIdentity' for extracting the final +-- result of pure effect interpretations. +----------------------------------------------------------------------------- +module Control.Effect.Identity + ( -- * Interpretations + runIdentity + ) where + +-- base +import qualified Data.Functor.Identity as I + +-- | Runs a computation using the 'I.Identity' monad. +-- +-- You usually need this when an expression of type @Monad m => m a@ remains +-- after handling all the effects and you want to extract its pure result. +runIdentity :: I.Identity a -> a +runIdentity = I.runIdentity +{-# INLINE runIdentity #-}