├── .gitignore ├── Setup.hs ├── test ├── ExpectedOutput.hs ├── FreeMonadSpec.hs ├── MainSpec.hs ├── BespokeMonadSpec.hs ├── ExtensibleEffectsSpec.hs └── MonadTransformersSpec.hs ├── .travis.yml ├── app └── Main.hs ├── scripts ├── Dockerfile └── lint-general.rb ├── LICENSE ├── README.md ├── src ├── MonadTransformers.hs ├── FreeMonad.hs ├── ModulesPure.hs ├── BespokeMonad.hs ├── Modules.hs └── ExtensibleEffects.hs ├── Makefile ├── effects.cabal └── stack.yaml /.gitignore: -------------------------------------------------------------------------------- 1 | .stack-work/* 2 | .vscode 3 | -------------------------------------------------------------------------------- /Setup.hs: -------------------------------------------------------------------------------- 1 | import Distribution.Simple 2 | 3 | main = defaultMain 4 | -------------------------------------------------------------------------------- /test/ExpectedOutput.hs: -------------------------------------------------------------------------------- 1 | module ExpectedOutput 2 | ( expectedOutput 3 | ) where 4 | 5 | expectedOutput :: String 6 | expectedOutput = "0\n3\n6\n9\n17\n17\n24\n25\n26\n27\n" 7 | -------------------------------------------------------------------------------- /.travis.yml: -------------------------------------------------------------------------------- 1 | os: linux 2 | dist: trusty 3 | language: generic 4 | sudo: required 5 | services: docker 6 | script: 7 | - while sleep 1m; do echo "=====[ still running ]====="; done & 8 | - make docker-build 9 | - kill %1 10 | -------------------------------------------------------------------------------- /test/FreeMonadSpec.hs: -------------------------------------------------------------------------------- 1 | module FreeMonadSpec 2 | ( spec 3 | ) where 4 | 5 | import ExpectedOutput (expectedOutput) 6 | import FreeMonad (interpret, program) 7 | import Test.Hspec (Spec, describe, it, shouldBe) 8 | 9 | spec :: Spec 10 | spec = 11 | describe "Free monad" $ 12 | it "should produce the correct output" $ 13 | snd (interpret program) `shouldBe` expectedOutput 14 | -------------------------------------------------------------------------------- /test/MainSpec.hs: -------------------------------------------------------------------------------- 1 | import qualified BespokeMonadSpec 2 | import qualified ExtensibleEffectsSpec 3 | import qualified FreeMonadSpec 4 | import qualified MonadTransformersSpec 5 | import Test.Hspec (hspec) 6 | 7 | main :: IO () 8 | main = 9 | hspec $ do 10 | BespokeMonadSpec.spec 11 | ExtensibleEffectsSpec.spec 12 | FreeMonadSpec.spec 13 | MonadTransformersSpec.spec 14 | -------------------------------------------------------------------------------- /test/BespokeMonadSpec.hs: -------------------------------------------------------------------------------- 1 | module BespokeMonadSpec 2 | ( spec 3 | ) where 4 | 5 | import BespokeMonad (interpret, program) 6 | import ExpectedOutput (expectedOutput) 7 | import Test.Hspec (Spec, describe, it, shouldBe) 8 | 9 | spec :: Spec 10 | spec = 11 | describe "Bespoke monad" $ 12 | it "should produce the correct output" $ 13 | snd (interpret program) `shouldBe` expectedOutput 14 | -------------------------------------------------------------------------------- /test/ExtensibleEffectsSpec.hs: -------------------------------------------------------------------------------- 1 | module ExtensibleEffectsSpec 2 | ( spec 3 | ) where 4 | 5 | import ExpectedOutput (expectedOutput) 6 | import ExtensibleEffects (interpret, program) 7 | import Test.Hspec (Spec, describe, it, shouldBe) 8 | 9 | spec :: Spec 10 | spec = 11 | describe "Extensible effects" $ 12 | it "should produce the correct output" $ 13 | snd (interpret program) `shouldBe` expectedOutput 14 | -------------------------------------------------------------------------------- /test/MonadTransformersSpec.hs: -------------------------------------------------------------------------------- 1 | module MonadTransformersSpec 2 | ( spec 3 | ) where 4 | 5 | import ExpectedOutput (expectedOutput) 6 | import MonadTransformers (interpret, program) 7 | import Test.Hspec (Spec, describe, it, shouldBe) 8 | 9 | spec :: Spec 10 | spec = 11 | describe "Monad transformers" $ 12 | it "should produce the correct output" $ 13 | snd (interpret program) `shouldBe` expectedOutput 14 | -------------------------------------------------------------------------------- /app/Main.hs: -------------------------------------------------------------------------------- 1 | module Main 2 | ( main 3 | ) where 4 | 5 | import qualified BespokeMonad 6 | import qualified ExtensibleEffects 7 | import qualified FreeMonad 8 | import qualified MonadTransformers 9 | import qualified Modules 10 | 11 | main :: IO () 12 | main = do 13 | putStrLn "Bespoke monad:\n" 14 | putStrLn . snd $ BespokeMonad.interpret BespokeMonad.program 15 | putStrLn "Extensible effects:\n" 16 | putStrLn . snd $ ExtensibleEffects.interpret ExtensibleEffects.program 17 | putStrLn "Free monad:\n" 18 | putStrLn . snd $ FreeMonad.interpret FreeMonad.program 19 | putStrLn "Monad transformers:\n" 20 | putStrLn . snd $ MonadTransformers.interpret MonadTransformers.program 21 | putStrLn "Modules:\n" 22 | Modules.app >>= Modules.run 23 | -------------------------------------------------------------------------------- /scripts/Dockerfile: -------------------------------------------------------------------------------- 1 | FROM debian:stretch 2 | 3 | RUN \ 4 | DEBIAN_FRONTEND=noninteractive apt-get -y update && \ 5 | DEBIAN_FRONTEND=noninteractive apt-get -y install \ 6 | 'build-essential=12.3' \ 7 | 'ruby=1:2.3.*' && \ 8 | rm -rf /var/lib/apt/lists/* && \ 9 | rm -rf /usr/share/doc 10 | 11 | # The Stack installation script apparently uses apt-get. 12 | RUN \ 13 | DEBIAN_FRONTEND=noninteractive apt-get -y update && \ 14 | DEBIAN_FRONTEND=noninteractive apt-get -y install 'curl=7.52.*' && \ 15 | curl -sSL https://get.haskellstack.org/ | sh && \ 16 | rm -rf /var/lib/apt/lists/* && \ 17 | rm -rf /usr/share/doc && \ 18 | DEBIAN_FRONTEND=noninteractive apt-get -y purge --auto-remove curl 19 | 20 | RUN useradd --user-group --create-home user 21 | 22 | USER user:user 23 | 24 | WORKDIR /home/user 25 | 26 | # Without this, Ruby will assume files are encoded as ASCII. 27 | RUN echo 'export LANG="C.UTF-8"' >> ~/.profile 28 | 29 | # Stack installs executables in $HOME/.local/bin. 30 | RUN \ 31 | mkdir -p "$HOME/.local/bin" && \ 32 | echo 'export PATH="$HOME/.local/bin:$PATH"' >> ~/.profile 33 | 34 | RUN stack setup --resolver lts-10.4 35 | 36 | RUN stack install hindent hlint 37 | -------------------------------------------------------------------------------- /LICENSE: -------------------------------------------------------------------------------- 1 | Copyright Stephan Boyer (c) 2018 2 | 3 | All rights reserved. 4 | 5 | Redistribution and use in source and binary forms, with or without 6 | modification, are permitted provided that the following conditions are met: 7 | 8 | * Redistributions of source code must retain the above copyright 9 | notice, this list of conditions and the following disclaimer. 10 | 11 | * Redistributions in binary form must reproduce the above 12 | copyright notice, this list of conditions and the following 13 | disclaimer in the documentation and/or other materials provided 14 | with the distribution. 15 | 16 | * Neither the name of the copyright holder nor the names of its 17 | contributors may be used to endorse or promote products derived 18 | from this software without specific prior written permission. 19 | 20 | THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS 21 | "AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT 22 | LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR 23 | A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT 24 | OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, 25 | SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT 26 | LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, 27 | DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY 28 | THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT 29 | (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE 30 | OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. 31 | -------------------------------------------------------------------------------- /README.md: -------------------------------------------------------------------------------- 1 | # Effects 2 | 3 | A brief exploration of the various approaches to modeling side effects in a purely functional programming language. 4 | 5 | [![Build Status](https://travis-ci.org/stepchowfun/effects.svg?branch=master)](https://travis-ci.org/stepchowfun/effects) 6 | 7 | ## The challenge 8 | 9 | Write a program that initializes an accumulator and random seed both with `0` and then runs the following procedure 10 times: 10 | 11 | - Log the value of the accumulator. 12 | - Pick an integer uniformly randomly from the half-open interval `[0, 10)`. 13 | - Mutate the accumulator by adding the random integer to it. 14 | 15 | Thus, 3 computational effects are exhibited: logging, randomness, and mutable state. 16 | 17 | ## Techniques demonstrated 18 | 19 | This repository contains 4 implementations of the program described above, each demonstrating a specific technique: 20 | 21 | - A [bespoke monad](https://github.com/stepchowfun/effects/blob/master/src/BespokeMonad.hs) 22 | - A standard [monad transformer stack](https://github.com/stepchowfun/effects/blob/master/src/MonadTransformers.hs) 23 | - A [free monad](https://github.com/stepchowfun/effects/blob/master/src/FreeMonad.hs) 24 | - The [`Eff` monad](https://github.com/stepchowfun/effects/blob/master/src/ExtensibleEffects.hs) from the "extensible effects" framework 25 | - A [Registry](https://github.com/etorreborre/effects/blob/master/src/Modules.hs) using the [`registry`](https://github.com/etorreborre/registry) library 26 | 27 | ## Instructions 28 | 29 | Make sure you have [Make](https://www.gnu.org/software/make/) and [Stack](https://docs.haskellstack.org/en/stable/README/) installed. Then you can use this command to run the demo: 30 | 31 | ``` 32 | make run 33 | ``` 34 | -------------------------------------------------------------------------------- /src/MonadTransformers.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE FlexibleContexts #-} 2 | 3 | module MonadTransformers 4 | ( Computation 5 | , interpret 6 | , program 7 | ) where 8 | 9 | {- 10 | - This example solves the challenge in the most standard way: with a monad 11 | - transformer stack. The idea of monad transformers came from [1]. 12 | - 13 | - [1] Sheng Liang, Paul Hudak, and Mark Jones. 1995. Monad transformers and 14 | - modular interpreters. In Proceedings of the 22nd ACM SIGPLAN-SIGACT 15 | - symposium on Principles of programming languages (POPL '95). ACM, New 16 | - York, NY, USA, 333-343. DOI=http://dx.doi.org/10.1145/199448.199528 17 | -} 18 | import Control.Monad (replicateM_) 19 | import Control.Monad.Random 20 | ( MonadRandom 21 | , Rand 22 | , StdGen 23 | , getRandomR 24 | , mkStdGen 25 | , runRand 26 | ) 27 | import Control.Monad.State (MonadState, StateT, get, put, runStateT) 28 | import Control.Monad.Writer (MonadWriter, WriterT, runWriterT, tell) 29 | 30 | -- The monad 31 | type Computation = WriterT String (StateT Integer (Rand StdGen)) 32 | 33 | -- The operations 34 | getRandom :: MonadRandom m => m Integer 35 | getRandom = getRandomR (0, 9) 36 | 37 | getAccumulator :: MonadState Integer m => m Integer 38 | getAccumulator = get 39 | 40 | setAccumulator :: MonadState Integer m => Integer -> m () 41 | setAccumulator = put 42 | 43 | logOutput :: MonadWriter String m => String -> m () 44 | logOutput = tell 45 | 46 | -- The program 47 | program :: (MonadRandom m, MonadState Integer m, MonadWriter String m) => m () 48 | program = 49 | replicateM_ 10 $ do 50 | i <- getAccumulator 51 | logOutput (show i ++ "\n") 52 | r <- getRandom 53 | setAccumulator (r + i) 54 | pure () 55 | 56 | -- An interpreter 57 | interpret :: Computation a -> (a, String) 58 | interpret c = 59 | let ((x, _), _) = runRand (runStateT (runWriterT c) 0) (mkStdGen 0) 60 | in x 61 | -------------------------------------------------------------------------------- /Makefile: -------------------------------------------------------------------------------- 1 | .PHONY: build run test lint format clean docker-deps docker-build 2 | 3 | build: 4 | stack build --pedantic --install-ghc --allow-different-user 5 | 6 | run: build 7 | stack exec effects-exe 8 | 9 | test: 10 | stack test --pedantic --install-ghc --allow-different-user 11 | 12 | lint: 13 | hlint . 14 | ./scripts/lint-general.rb $(shell \ 15 | find . -type d \( \ 16 | -path ./.git -o \ 17 | -path ./.stack-work \ 18 | \) -prune -o \( \ 19 | -name '*.hs' -o \ 20 | -name '*.rb' -o \ 21 | -name '*.sh' -o \ 22 | -name '*.yml' -o \ 23 | -name 'Dockerfile' -o \ 24 | -name 'Makefile' \ 25 | \) -print \ 26 | ) 27 | for file in $(shell \ 28 | find . -type d \( \ 29 | -path ./.git -o \ 30 | -path ./.stack-work \ 31 | \) -prune -o \( \ 32 | -name '*.hs' \ 33 | \) -print \ 34 | ); do \ 35 | cat "$$file" | hindent --line-length 79 > "$$file.tmp"; \ 36 | (cmp "$$file.tmp" "$$file" && rm "$$file.tmp") || \ 37 | (rm "$$file.tmp" && false) || exit 1; \ 38 | done 39 | 40 | format: 41 | for file in $(shell \ 42 | find . -type d \( \ 43 | -path ./.git -o \ 44 | -path ./.stack-work \ 45 | \) -prune -o \( \ 46 | -name '*.hs' \ 47 | \) -print \ 48 | ); do \ 49 | cat "$$file" | hindent --line-length 79 > "$$file.tmp"; \ 50 | (cmp --quiet "$$file.tmp" "$$file" && rm "$$file.tmp") || \ 51 | mv "$$file.tmp" "$$file"; \ 52 | done 53 | 54 | clean: 55 | rm -rf .stack-work 56 | 57 | docker-deps: 58 | docker build -f scripts/Dockerfile -t stephanmisc/effects:deps . 59 | 60 | docker-build: 61 | CONTAINER="$$( \ 62 | docker create --rm --user=root stephanmisc/effects:deps \ 63 | bash -c ' \ 64 | chown -R user:user repo && \ 65 | cd repo && \ 66 | su user -s /bin/bash -l -c " \ 67 | cd repo && make clean && make build run test lint \ 68 | " \ 69 | ' \ 70 | )" && \ 71 | docker cp . "$$CONTAINER:/home/user/repo" && \ 72 | docker start --attach "$$CONTAINER" 73 | -------------------------------------------------------------------------------- /src/FreeMonad.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE DeriveFunctor #-} 2 | 3 | module FreeMonad 4 | ( interpret 5 | , program 6 | ) where 7 | 8 | {- 9 | - This example solves the challenge with a free monad. The use of free monads 10 | - to structure programs was popularized by [1]. 11 | - 12 | - [1] Wouter Swierstra. 2008. Data types à la carte. J. Funct. Program. 18, 4 13 | - (July 2008), 423-436. DOI=http://dx.doi.org/10.1017/S0956796808006758 14 | -} 15 | import Control.Monad (replicateM_) 16 | import Control.Monad.Free (Free(..), foldFree, liftF) 17 | import Control.Monad.Random (getRandomR) 18 | import Control.Monad.State (get, put) 19 | import Control.Monad.Writer (tell) 20 | import qualified MonadTransformers 21 | 22 | -- The monad 23 | type Computation = Free Operations 24 | 25 | -- The operations 26 | data Operations a 27 | = GetRandom (Integer -> a) 28 | | GetAccumulator (Integer -> a) 29 | | SetAccumulator Integer 30 | a 31 | | LogOutput String 32 | a 33 | deriving (Functor) 34 | 35 | getRandom :: Computation Integer 36 | getRandom = liftF (GetRandom id) 37 | 38 | getAccumulator :: Computation Integer 39 | getAccumulator = liftF (GetAccumulator id) 40 | 41 | setAccumulator :: Integer -> Computation () 42 | setAccumulator i = liftF (SetAccumulator i ()) 43 | 44 | logOutput :: String -> Computation () 45 | logOutput s = liftF (LogOutput s ()) 46 | 47 | -- The program 48 | program :: Computation () 49 | program = 50 | replicateM_ 10 $ do 51 | i <- getAccumulator 52 | logOutput (show i ++ "\n") 53 | r <- getRandom 54 | setAccumulator (r + i) 55 | pure () 56 | 57 | -- An interpreter 58 | transform :: Operations a -> MonadTransformers.Computation a 59 | transform (GetRandom k) = k <$> getRandomR (0, 9) 60 | transform (GetAccumulator k) = k <$> get 61 | transform (SetAccumulator i k) = k <$ put i 62 | transform (LogOutput s k) = k <$ tell s 63 | 64 | interpret :: Computation a -> (a, String) 65 | interpret c = MonadTransformers.interpret (foldFree transform c) 66 | -------------------------------------------------------------------------------- /src/ModulesPure.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE DataKinds #-} 2 | {-# LANGUAGE Rank2Types #-} 3 | {-# LANGUAGE RecordWildCards #-} 4 | {-# LANGUAGE ScopedTypeVariables #-} 5 | {-# LANGUAGE TypeApplications #-} 6 | 7 | {- 8 | Pure instantiation of the application 9 | -} 10 | module ModulesPure where 11 | 12 | import Control.Monad.Random (Rand, StdGen, getRandomR, mkStdGen, 13 | runRand) 14 | import Control.Monad.State as State (MonadState, StateT, runStateT, get, modify) 15 | import Control.Monad.Writer (MonadWriter, WriterT, runWriterT, tell) 16 | import Data.Registry 17 | import Modules 18 | import Protolude as P hiding (get) 19 | import System.Random (getStdRandom, randomR) 20 | 21 | -- Pure interface for the components 22 | type P = WriterT String (StateT Int (Rand StdGen)) 23 | 24 | -- | Top level application, created from the registry 25 | appPure :: App P 26 | appPure = make @(App P) registryPure 27 | 28 | registryPure :: Registry 29 | -- inputs for constructors in the registry 30 | '[Logger P, Random P, Accumulator P] 31 | -- outputs for constructors in the registry 32 | '[Accumulator P, Logger P, Random P, App P] 33 | registryPure = 34 | fun newAccumulatorPure 35 | +: fun newLoggerPure 36 | +: fun newRandomPure 37 | +: fun newAppPure 38 | +: end 39 | 40 | newLoggerPure :: Logger P 41 | newLoggerPure = Logger (tell . P.show) 42 | 43 | newRandomPure :: Random P 44 | newRandomPure = 45 | Random { 46 | draw = \l h -> getRandomR (l, h) 47 | } 48 | 49 | newAccumulatorPure :: Accumulator P 50 | newAccumulatorPure = 51 | Accumulator { 52 | add = \n -> State.modify (+n) 53 | , get = State.get 54 | } 55 | 56 | newAppPure :: Logger P -> Random P -> Accumulator P -> App P 57 | newAppPure Logger{..} Random{..} Accumulator{..} = App { 58 | run = replicateM_ 10 $ 59 | do current <- get 60 | _ <- info current 61 | picked <- draw 0 9 62 | add picked 63 | } 64 | -------------------------------------------------------------------------------- /scripts/lint-general.rb: -------------------------------------------------------------------------------- 1 | #!/usr/bin/env ruby 2 | 3 | # This script applies basic general linting to a list of source files. 4 | # 5 | # Usage: 6 | # ./scripts/lint-general.rb path1 path2 path3 ... 7 | 8 | # Iterate over the input files. 9 | ARGV.each do |path| 10 | # Read the contents of the file. 11 | lines = File.read(path).split("\n", -1) 12 | 13 | # Iterate over the lines of the file. 14 | lines.each_with_index do |line, index| 15 | # Check for tabs, with special behavior for files called `Makefile`. 16 | if File.basename(path) == 'Makefile' 17 | # Check for tabs which are not the first character of the line. 18 | if line =~ /.\t/ 19 | STDERR.puts( 20 | "Error: Line #{index + 1} of #{path} has a tab in a non-required " \ 21 | "position." 22 | ) 23 | exit(1) 24 | end 25 | else 26 | # Check for any tabs. 27 | if line =~ /\t/ 28 | STDERR.puts( 29 | "Error: Line #{index + 1} of #{path} has a tab." 30 | ) 31 | exit(1) 32 | end 33 | end 34 | 35 | # Check the line length. 36 | if line.bytesize > 79 37 | STDERR.puts( 38 | "Error: Line #{index + 1} of #{path} has #{line.bytesize} bytes, " \ 39 | "which is more than 79." 40 | ) 41 | exit(1) 42 | end 43 | 44 | # Check for trailing whitespace. 45 | if line =~ /\s$/ 46 | STDERR.puts( 47 | "Error: Line #{index + 1} of #{path} has trailing whitespace." 48 | ) 49 | exit(1) 50 | end 51 | end 52 | 53 | # Check for blank lines at the end of the file. 54 | if !lines.empty? 55 | # Check that there is a blank line at the end of the file. 56 | if !lines.last.empty? 57 | STDERR.puts( 58 | "Error: #{path} is not terminated by a blank line." 59 | ) 60 | exit(1) 61 | end 62 | 63 | # Check that there are not multiple blank lines at the end of the file. 64 | if lines.size > 1 65 | if lines[lines.size - 2].empty? 66 | STDERR.puts( 67 | "Error: #{path} is terminated by more than one blank line." 68 | ) 69 | exit(1) 70 | end 71 | end 72 | end 73 | end 74 | -------------------------------------------------------------------------------- /effects.cabal: -------------------------------------------------------------------------------- 1 | name: effects 2 | version: 0.1.0.0 3 | -- synopsis: 4 | -- description: 5 | homepage: https://github.com/stepchowfun/effects#readme 6 | license: BSD3 7 | license-file: LICENSE 8 | author: Stephan Boyer 9 | maintainer: stephan@stephanboyer.com 10 | copyright: (c) 2018 Stephan Boyer 11 | category: Web 12 | build-type: Simple 13 | extra-source-files: README.md 14 | cabal-version: >= 1.10 15 | 16 | library 17 | hs-source-dirs: src 18 | exposed-modules: BespokeMonad 19 | , ExtensibleEffects 20 | , FreeMonad 21 | , Modules 22 | , ModulesPure 23 | , MonadTransformers 24 | build-depends: MonadRandom 25 | , base >= 4.7 && < 5 26 | , extensible-effects 27 | , free 28 | , mtl 29 | , protolude 30 | , random 31 | , registry 32 | default-language: Haskell2010 33 | 34 | ghc-options: -fhide-source-paths 35 | 36 | executable effects-exe 37 | hs-source-dirs: app 38 | main-is: Main.hs 39 | ghc-options: -threaded -rtsopts -with-rtsopts=-N -fhide-source-paths 40 | build-depends: base 41 | , effects 42 | default-language: Haskell2010 43 | 44 | test-suite effects-test 45 | type: exitcode-stdio-1.0 46 | hs-source-dirs: test 47 | main-is: MainSpec.hs 48 | other-modules: BespokeMonadSpec 49 | , ExpectedOutput 50 | , ExtensibleEffectsSpec 51 | , FreeMonadSpec 52 | , MonadTransformersSpec 53 | build-depends: MonadRandom 54 | , base 55 | , effects 56 | , extensible-effects 57 | , hspec 58 | , hspec-core 59 | , mtl 60 | , random 61 | ghc-options: -threaded -rtsopts -with-rtsopts=-N -fhide-source-paths 62 | default-language: Haskell2010 63 | 64 | source-repository head 65 | type: git 66 | location: https://github.com/stepchowfun/effects 67 | -------------------------------------------------------------------------------- /stack.yaml: -------------------------------------------------------------------------------- 1 | # This file was automatically generated by 'stack init' 2 | # 3 | # Some commonly used options have been documented as comments in this file. 4 | # For advanced use and comprehensive documentation of the format, please see: 5 | # http://docs.haskellstack.org/en/stable/yaml_configuration/ 6 | 7 | # Resolver to choose a 'specific' stackage snapshot or a compiler version. 8 | # A snapshot resolver dictates the compiler version and the set of packages 9 | # to be used for project dependencies. For example: 10 | # 11 | # resolver: lts-3.5 12 | # resolver: nightly-2015-09-21 13 | # resolver: ghc-7.10.2 14 | # resolver: ghcjs-0.1.0_ghc-7.10.2 15 | # resolver: 16 | # name: custom-snapshot 17 | # location: "./custom-snapshot.yaml" 18 | resolver: lts-10.4 19 | 20 | # User packages to be built. 21 | # Various formats can be used as shown in the example below. 22 | # 23 | # packages: 24 | # - some-directory 25 | # - https://example.com/foo/bar/baz-0.0.2.tar.gz 26 | # - location: 27 | # git: https://github.com/commercialhaskell/stack.git 28 | # commit: e7b331f14bcffb8367cd58fbfc8b40ec7642100a 29 | # - location: https://github.com/commercialhaskell/stack/commit/e7b331f14bcffb8367cd58fbfc8b40ec7642100a 30 | # extra-dep: true 31 | # subdirs: 32 | # - auto-update 33 | # - wai 34 | # 35 | # A package marked 'extra-dep: true' will only be built if demanded by a 36 | # non-dependency (i.e. a user package), and its test suites and benchmarks 37 | # will not be run. This is useful for tweaking upstream packages. 38 | packages: 39 | - '.' 40 | # Dependency packages to be pulled from upstream that are not in the resolver 41 | # (e.g., acme-missiles-0.3) 42 | extra-deps: 43 | - extensible-effects-3.1.0.0 44 | - registry-0.1.0.4 45 | 46 | # Override default flag values for local packages and extra-deps 47 | flags: {} 48 | 49 | # Extra package databases containing global packages 50 | extra-package-dbs: [] 51 | 52 | # Control whether we use the GHC we find on the path 53 | # system-ghc: true 54 | # 55 | # Require a specific version of stack, using version ranges 56 | # require-stack-version: -any # Default 57 | # require-stack-version: ">=1.4" 58 | # 59 | # Override the architecture used by stack, especially useful on Windows 60 | # arch: i386 61 | # arch: x86_64 62 | # 63 | # Extra directories used by stack for building 64 | # extra-include-dirs: [/path/to/dir] 65 | # extra-lib-dirs: [/path/to/dir] 66 | # 67 | # Allow a newer minor version of GHC than the snapshot specifies 68 | # compiler-check: newer-minor 69 | -------------------------------------------------------------------------------- /src/BespokeMonad.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE DeriveFunctor #-} 2 | 3 | module BespokeMonad 4 | ( interpret 5 | , program 6 | ) where 7 | 8 | {- 9 | - This example solves the challenge with a handcrafted monad. This is as basic 10 | - as it gets: no monad transformers, no free monads, no extensible effects, 11 | - etc. The use of monads to describe the denotational semantics of effectful 12 | - programs was first described in [1]. In the following year, [2] showed how 13 | - monads could be used to structure programs rather than reason about them. 14 | - 15 | - [1] E. Moggi. 1989. Computational lambda-calculus and monads. In Proceedings 16 | - of the Fourth Annual Symposium on Logic in computer science. IEEE Press, 17 | - Piscataway, NJ, USA, 14-23. 18 | - 19 | - [2] Philip Wadler. 1990. Comprehending monads. In Proceedings of the 1990 20 | - ACM conference on LISP and functional programming (LFP '90). ACM, New 21 | - York, NY, USA, 61-78. DOI=http://dx.doi.org/10.1145/91556.91592 22 | -} 23 | import Control.Monad (ap, replicateM_) 24 | import System.Random (StdGen, mkStdGen, randomR) 25 | 26 | -- The monad 27 | newtype Computation a = Computation 28 | { runComputation :: StdGen -> Integer -> (StdGen, Integer, String, a) 29 | } deriving (Functor) 30 | 31 | instance Applicative Computation where 32 | pure x = Computation $ \g i -> (g, i, "", x) 33 | (<*>) = ap 34 | 35 | instance Monad Computation where 36 | c >>= f = 37 | Computation $ \g1 i1 -> 38 | let (g2, i2, s2, x2) = runComputation c g1 i1 39 | (g3, i3, s3, x3) = runComputation (f x2) g2 i2 40 | in (g3, i3, s2 ++ s3, x3) 41 | 42 | -- The operations 43 | getRandom :: Computation Integer 44 | getRandom = 45 | Computation $ \g1 i -> 46 | let (r, g2) = randomR (0, 9) g1 47 | in (g2, i, "", r) 48 | 49 | getAccumulator :: Computation Integer 50 | getAccumulator = Computation $ \g i -> (g, i, "", i) 51 | 52 | setAccumulator :: Integer -> Computation () 53 | setAccumulator i = Computation $ \g _ -> (g, i, "", ()) 54 | 55 | logOutput :: String -> Computation () 56 | logOutput s = Computation $ \g i -> (g, i, s, ()) 57 | 58 | -- The program 59 | program :: Computation () 60 | program = 61 | replicateM_ 10 $ do 62 | i <- getAccumulator 63 | logOutput (show i ++ "\n") 64 | r <- getRandom 65 | setAccumulator (r + i) 66 | pure () 67 | 68 | -- An interpreter 69 | interpret :: Computation a -> (a, String) 70 | interpret (Computation k) = 71 | let (_, _, o, x) = k (mkStdGen 0) 0 72 | in (x, o) 73 | -------------------------------------------------------------------------------- /src/Modules.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE DataKinds #-} 2 | {-# LANGUAGE Rank2Types #-} 3 | {-# LANGUAGE ScopedTypeVariables #-} 4 | {-# LANGUAGE TypeApplications #-} 5 | {-# LANGUAGE RecordWildCards #-} 6 | 7 | module Modules where 8 | 9 | {- 10 | 11 | Here we describe functionalities with simple datatypes, records of functions, 12 | and call them "modules" 13 | 14 | Then we define "constructors" those modules and specify how they depend on 15 | each other. 16 | 17 | Finally we put them in a "Registry" with the https://github.com/etorreborre/registry 18 | package and wire all of them into a top-level "App" running the whole program using 19 | all the "Modules" 20 | 21 | -} 22 | import Data.IORef 23 | import Data.Registry 24 | import Protolude as P hiding (get) 25 | import System.Random (getStdRandom, randomR) 26 | 27 | -- | Top level application, created from the registry 28 | app :: IO (App IO) 29 | app = make @(IO (App IO)) registry 30 | 31 | registry :: Registry 32 | -- inputs for constructors in the registry 33 | '[IO (Logger IO), IO (Random IO), IO (Accumulator IO)] 34 | -- outputs for constructors in the registry 35 | '[IO (Accumulator IO), IO (Logger IO), IO (Random IO), IO (App IO)] 36 | registry = 37 | fun newAccumulator 38 | +: funTo @IO newLogger 39 | +: funTo @IO newRandom 40 | +: funTo @IO newApp 41 | +: end 42 | 43 | -- * Logging module, can go into its own library 44 | 45 | newtype Logger m = Logger { 46 | info :: forall a . (Show a) => a -> m () 47 | } 48 | 49 | newLogger :: Logger IO 50 | newLogger = Logger P.print 51 | 52 | -- * Random module, implemented using the global random generator 53 | -- for simplicity 54 | 55 | newtype Random m = Random { 56 | draw :: Int -> Int -> m Int 57 | } 58 | 59 | newRandom :: Random IO 60 | newRandom = 61 | Random { 62 | draw = \l h -> getStdRandom (randomR (l, h)) 63 | } 64 | 65 | -- * Accumulator module 66 | -- the constructor for this module is effectful 67 | -- because we instantiate an IORef 68 | 69 | data Accumulator m = Accumulator { 70 | add :: Int -> m () 71 | , get :: m Int 72 | } 73 | 74 | newAccumulator :: IO (Accumulator IO) 75 | newAccumulator = do 76 | counter <- newIORef 0 77 | pure Accumulator { 78 | add = \n -> modifyIORef counter (+n) 79 | , get = readIORef counter 80 | } 81 | 82 | -- * The top-level app containing the main program 83 | -- It depends on other modules for its implementation 84 | 85 | newtype App m = App { 86 | run :: m () 87 | } 88 | 89 | newApp :: Logger IO -> Random IO -> Accumulator IO -> App IO 90 | newApp Logger{..} Random{..} Accumulator{..} = App { 91 | run = replicateM_ 10 $ 92 | do current <- get 93 | _ <- info current 94 | picked <- draw 0 9 95 | add picked 96 | } 97 | -------------------------------------------------------------------------------- /src/ExtensibleEffects.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE DataKinds #-} 2 | {-# LANGUAGE ExplicitForAll #-} 3 | {-# LANGUAGE FlexibleContexts #-} 4 | {-# LANGUAGE GADTs #-} 5 | {-# LANGUAGE MonoLocalBinds #-} 6 | {-# LANGUAGE RankNTypes #-} 7 | {-# LANGUAGE TypeOperators #-} 8 | 9 | module ExtensibleEffects 10 | ( interpret 11 | , program 12 | ) where 13 | 14 | {- 15 | - This example solves the challenge with the "extensible effects" framework 16 | - originally proposed in [1] and elaborated in [2]. 17 | - 18 | - [1] Oleg Kiselyov, Amr Sabry, and Cameron Swords. 2013. Extensible effects: 19 | - an alternative to monad transformers. In Proceedings of the 2013 ACM 20 | - SIGPLAN symposium on Haskell (Haskell '13). ACM, New York, NY, USA, 21 | - 59-70. DOI=http://dx.doi.org/10.1145/2503778.2503791 22 | - 23 | - [2] Oleg Kiselyov and Hiromi Ishii. 2015. Freer monads, more extensible 24 | - effects. In Proceedings of the 2015 ACM SIGPLAN Symposium on Haskell 25 | - (Haskell '15). ACM, New York, NY, USA, 94-105. 26 | - DOI=http://dx.doi.org/10.1145/2804302.2804319 27 | -} 28 | import Control.Eff (Eff, Member, run) 29 | import Control.Eff.Extend (handle_relay_s, send) 30 | import Control.Eff.State.Lazy (State, get, put, runState) 31 | import Control.Eff.Writer.Lazy (Writer, runMonoidWriter, tell) 32 | import Control.Monad (replicateM_) 33 | import Data.Typeable (Typeable) 34 | import System.Random (mkStdGen, randomR) 35 | 36 | -- A custom effect 37 | data Random a where 38 | GetRandom :: Random Integer 39 | deriving (Typeable) 40 | 41 | -- The operations 42 | getRandom :: Member Random r => Eff r Integer 43 | getRandom = send GetRandom 44 | 45 | getAccumulator :: Member (State Integer) r => Eff r Integer 46 | getAccumulator = get 47 | 48 | setAccumulator :: Member (State Integer) r => Integer -> Eff r () 49 | setAccumulator = put 50 | 51 | logOutput :: Member (Writer String) r => String -> Eff r () 52 | logOutput = tell 53 | 54 | -- The program 55 | program :: 56 | (Member Random r, Member (State Integer) r, Member (Writer String) r) 57 | => Eff r () 58 | program = 59 | replicateM_ 10 $ do 60 | i <- getAccumulator 61 | logOutput (show i ++ "\n") 62 | r <- getRandom 63 | setAccumulator (r + i) 64 | pure () 65 | 66 | -- A custom effect handler 67 | runRandom :: Eff (Random ': r) a -> Eff r a 68 | runRandom = 69 | handle_relay_s 70 | (mkStdGen 0) 71 | (const pure) 72 | (\s1 GetRandom k -> 73 | let (r, s2) = randomR (0, 9) s1 74 | in k s2 r) 75 | 76 | -- An interpreter 77 | interpret :: 78 | (forall r. ( Member Random r 79 | , Member (State Integer) r 80 | , Member (Writer String) r 81 | ) => 82 | Eff r a) 83 | -> (a, String) 84 | interpret c = 85 | let ((x, o), _) = 86 | run . runState (0 :: Integer) . runMonoidWriter . runRandom $ c 87 | in (x, o) 88 | --------------------------------------------------------------------------------