├── .gitignore ├── .travis.yml ├── CODE_OF_CONDUCT.md ├── HLint.hs ├── LICENSE ├── README.md ├── Setup.hs ├── bench └── Core.hs ├── changelog.md ├── effects.cabal ├── examples └── src │ ├── Common.hs │ ├── Coroutine.hs │ ├── Cut.hs │ ├── Fresh.hs │ ├── Main.hs │ ├── NonDet.hs │ ├── Teletype.hs │ └── Trace.hs ├── src ├── Control │ └── Monad │ │ ├── Effect.hs │ │ └── Effect │ │ ├── Coroutine.hs │ │ ├── Cut.hs │ │ ├── Exception.hs │ │ ├── Fail.hs │ │ ├── Fresh.hs │ │ ├── Internal.hs │ │ ├── NonDet.hs │ │ ├── Reader.hs │ │ ├── Resource.hs │ │ ├── Resumable.hs │ │ ├── State.hs │ │ ├── StateRW.hs │ │ ├── Trace.hs │ │ └── Writer.hs └── Data │ └── Union.hs ├── stack.yaml └── tests ├── Tests.hs └── Tests ├── Common.hs ├── Coroutine.hs ├── Exception.hs ├── Fresh.hs ├── NonDet.hs ├── Reader.hs ├── State.hs ├── StateRW.hs └── Union.hs /.gitignore: -------------------------------------------------------------------------------- 1 | # haskell 2 | .stack-work 3 | .cabal-sandbox 4 | dist 5 | cabal.sandbox.config 6 | 7 | # emacs 8 | TAGS 9 | tags 10 | -------------------------------------------------------------------------------- /.travis.yml: -------------------------------------------------------------------------------- 1 | # Use new container infrastructure to enable caching 2 | sudo: false 3 | 4 | # Do not choose a language; we provide our own build tools. 5 | language: generic 6 | 7 | # Caching so the next build will be fast too. 8 | cache: 9 | directories: 10 | - $HOME/.stack 11 | 12 | # Ensure necessary system libraries are present 13 | addons: 14 | apt: 15 | packages: 16 | - libgmp-dev 17 | 18 | before_install: 19 | # Download and unpack the stack executable 20 | - mkdir -p ~/.local/bin 21 | - export PATH=$HOME/.local/bin:$PATH 22 | - travis_retry curl -L https://get.haskellstack.org/stable/linux-x86_64.tar.gz | tar xz --wildcards --strip-components=1 -C ~/.local/bin '*/stack' 23 | 24 | install: 25 | # Build dependencies 26 | - stack --no-terminal --install-ghc test --only-dependencies 27 | 28 | script: 29 | # Build the package, its tests, and its docs and run the tests 30 | - stack --no-terminal test --haddock --no-haddock-deps -------------------------------------------------------------------------------- /CODE_OF_CONDUCT.md: -------------------------------------------------------------------------------- 1 | # Contributor Code of Conduct 2 | 3 | As contributors and maintainers of this project, and in the interest 4 | of fostering an open and welcoming community, we pledge to respect all 5 | people who contribute through reporting issues, posting feature 6 | requests, updating documentation, submitting pull requests or patches, 7 | and other activities. 8 | 9 | We are committed to making participation in this project a 10 | harassment-free experience for everyone, regardless of level of 11 | experience, gender, gender identity and expression, sexual 12 | orientation, disability, personal appearance, body size, race, 13 | ethnicity, age, religion, or nationality. 14 | 15 | Examples of unacceptable behavior by participants include: 16 | 17 | * The use of sexualized language or imagery 18 | * Personal attacks 19 | * Trolling or insulting/derogatory comments 20 | * Public or private harassment 21 | * Publishing other's private information, such as physical or 22 | electronic addresses, without explicit permission 23 | * Other unethical or unprofessional conduct. 24 | 25 | Project maintainers have the right and responsibility to remove, edit, 26 | or reject comments, commits, code, wiki edits, issues, and other 27 | contributions that are not aligned to this Code of Conduct. By 28 | adopting this Code of Conduct, project maintainers commit themselves 29 | to fairly and consistently applying these principles to every aspect 30 | of managing this project. Project maintainers who do not follow or 31 | enforce the Code of Conduct may be permanently removed from the 32 | project team. 33 | 34 | This code of conduct applies both within project spaces and in public 35 | spaces when an individual is representing the project or its 36 | community. 37 | 38 | Instances of abusive, harassing, or otherwise unacceptable behavior 39 | may be reported by opening an issue or contacting one or more of the 40 | project maintainers. 41 | 42 | This Code of Conduct is adapted from the 43 | [Contributor Covenant](http://contributor-covenant.org), version 44 | 1.2.0, available at 45 | [http://contributor-covenant.org/version/1/2/0/](http://contributor-covenant.org/version/1/2/0/) 46 | -------------------------------------------------------------------------------- /HLint.hs: -------------------------------------------------------------------------------- 1 | import "hint" HLint.Default 2 | import "hint" HLint.Dollar 3 | import "hint" HLint.Generalise 4 | 5 | ignore "Use mappend" 6 | error "generalize ++" = (++) ==> (<>) 7 | -- AMP fallout 8 | error "generalize mapM" = mapM ==> traverse 9 | error "generalize mapM_" = mapM_ ==> traverse_ 10 | error "generalize forM" = forM ==> for 11 | error "generalize forM_" = forM_ ==> for_ 12 | error "Avoid return" = 13 | return ==> pure 14 | where note = "return is obsolete as of GHC 7.10" 15 | 16 | error "use pure" = free . Pure ==> pure 17 | error "use wrap" = free . Free ==> wrap 18 | 19 | error "use extract" = headF . runCofree ==> extract 20 | -------------------------------------------------------------------------------- /LICENSE: -------------------------------------------------------------------------------- 1 | Original work Copyright (c) 2016, Allele Dev 2 | Modified work Copyright 2016 Josh Vera 3 | 4 | All rights reserved. 5 | 6 | Redistribution and use in source and binary forms, with or without 7 | modification, are permitted provided that the following conditions are met: 8 | 9 | * Redistributions of source code must retain the above copyright 10 | notice, this list of conditions and the following disclaimer. 11 | 12 | * Redistributions in binary form must reproduce the above 13 | copyright notice, this list of conditions and the following 14 | disclaimer in the documentation and/or other materials provided 15 | with the distribution. 16 | 17 | * Neither the name of Allele Dev nor the names of other 18 | contributors may be used to endorse or promote products derived 19 | from this software without specific prior written permission. 20 | 21 | THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS 22 | "AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT 23 | LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR 24 | A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT 25 | OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, 26 | SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT 27 | LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, 28 | DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY 29 | THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT 30 | (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE 31 | OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. 32 | -------------------------------------------------------------------------------- /README.md: -------------------------------------------------------------------------------- 1 | # Effects: Extensible Effects with Freer Monads 2 | 3 | Effects is an implementation of 4 | ["Freer Monads, More Extensible Effects"](http://okmij.org/ftp/Haskell/extensible/more.pdf). Much 5 | of the implementation is a repackaging and cleaning up of the 6 | reference materials provided 7 | [here](http://okmij.org/ftp/Haskell/extensible/). 8 | 9 | # Features 10 | 11 | The key features of Effects are: 12 | 13 | * An efficient effect system for Haskell as a library 14 | * Implementations for several common Haskell monad instances: 15 | * Reader 16 | * Writer 17 | * State 18 | * StateRW: State in terms of Reader/Writer 19 | * Trace 20 | * Exception 21 | * Core components for defining your own Effects 22 | 23 | # Example: Teletype DSL 24 | 25 | Here's what using Effects looks like: 26 | 27 | ```haskell 28 | {-# LANGUAGE GADTs #-} 29 | {-# LANGUAGE FlexibleContexts #-} 30 | {-# LANGUAGE TypeOperators #-} 31 | {-# LANGUAGE DataKinds #-} 32 | module Teletype where 33 | 34 | import Control.Monad.Effect 35 | import Control.Monad.Effect.Internal 36 | import System.Exit hiding (ExitSuccess) 37 | 38 | -------------------------------------------------------------------------------- 39 | -- Effect Model -- 40 | -------------------------------------------------------------------------------- 41 | data Teletype s where 42 | PutStrLn :: String -> Teletype () 43 | GetLine :: Teletype String 44 | ExitSuccess :: Teletype () 45 | 46 | putStrLn' :: Member Teletype r => String -> Eff r () 47 | putStrLn' = send . PutStrLn 48 | 49 | getLine' :: Member Teletype r => Eff r String 50 | getLine' = send GetLine 51 | 52 | exitSuccess' :: Member Teletype r => Eff r () 53 | exitSuccess' = send ExitSuccess 54 | 55 | -------------------------------------------------------------------------------- 56 | -- Effectful Interpreter -- 57 | -------------------------------------------------------------------------------- 58 | runTeletype :: Eff '[Teletype] w -> IO w 59 | runTeletype (Val x) = return x 60 | runTeletype (E u q) = case decompose u of 61 | Right (PutStrLn msg) -> putStrLn msg >> runTeletype (apply q ()) 62 | Right GetLine -> getLine >>= \s -> runTeletype (apply q s) 63 | Right ExitSuccess -> exitSuccess 64 | Left _ -> error "This cannot happen" 65 | 66 | -------------------------------------------------------------------------------- 67 | -- Pure Interpreter -- 68 | -------------------------------------------------------------------------------- 69 | runTeletypePure :: [String] -> Eff '[Teletype] w -> [String] 70 | runTeletypePure inputs req = reverse (go inputs req []) 71 | where go :: [String] -> Eff '[Teletype] w -> [String] -> [String] 72 | go _ (Val _) acc = acc 73 | go [] _ acc = acc 74 | go (x:xs) (E u q) acc = case decompose u of 75 | Right (PutStrLn msg) -> go (x:xs) (apply q ()) (msg:acc) 76 | Right GetLine -> go xs (apply q x) acc 77 | Right ExitSuccess -> go xs (Val ()) acc 78 | Left _ -> go xs (Val ()) acc 79 | ``` 80 | 81 | # Contributing 82 | 83 | Contributions are welcome! Documentation, examples, code, and 84 | feedback - they all help. 85 | 86 | Be sure to review the included code of conduct. This project adheres 87 | to the [Contributor's Covenant](http://contributor-covenant.org/). By 88 | participating in this project you agree to abide by its terms. 89 | 90 | ## Developer Setup 91 | 92 | The easiest way to start contributing is to install 93 | [stack](https://github.com/commercialhaskell/stack). stack can install 94 | GHC/Haskell for you, and automates common developer tasks. 95 | 96 | The key commands are: 97 | 98 | * stack setup : install GHC 99 | * stack build 100 | * stack clean 101 | * stack haddock : builds documentation 102 | * stack test 103 | * stack bench 104 | * stack ghci : start a REPL instance 105 | 106 | # Licensing 107 | 108 | This project is distributed under a BSD3 license. See the included 109 | LICENSE file for more details. 110 | 111 | # Acknowledgements 112 | 113 | This package would not be possible without the paper and the reference 114 | implementation. In particular: 115 | 116 | * Data.Union maps to [OpenUnion51.hs](http://okmij.org/ftp/Haskell/extensible/OpenUnion51.hs) 117 | * Data.FTCQueue maps to [FTCQueue1](http://okmij.org/ftp/Haskell/extensible/FTCQueue1.hs) 118 | * Control.Monad.Effect* maps to [Eff1.hs](http://okmij.org/ftp/Haskell/extensible/Eff1.hs) 119 | 120 | There will be deviations from the source. 121 | -------------------------------------------------------------------------------- /Setup.hs: -------------------------------------------------------------------------------- 1 | import Distribution.Simple 2 | main = defaultMain 3 | -------------------------------------------------------------------------------- /bench/Core.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE NoMonomorphismRestriction #-} 2 | {-# LANGUAGE FlexibleContexts #-} 3 | {-# LANGUAGE ScopedTypeVariables #-} 4 | {-# LANGUAGE GADTs #-} 5 | {-# LANGUAGE DataKinds #-} 6 | {-# LANGUAGE TypeOperators #-} 7 | {-# LANGUAGE DeriveFunctor #-} 8 | module Main where 9 | 10 | import Control.Monad 11 | import Control.Monad.Effect 12 | import Control.Monad.Effect.Internal 13 | import Control.Monad.Effect.Exception 14 | import Control.Monad.Effect.State 15 | import Control.Monad.Effect.StateRW 16 | 17 | import Criterion 18 | import Criterion.Main 19 | import qualified Control.Monad.State as MTL 20 | import qualified Control.Monad.Except as MTL 21 | import qualified Control.Monad.Free as Free 22 | 23 | -------------------------------------------------------------------------------- 24 | -- State Benchmarks -- 25 | -------------------------------------------------------------------------------- 26 | oneGet :: Int -> (Int, Int) 27 | oneGet n = run (runState get n) 28 | 29 | countDown :: Int -> (Int,Int) 30 | countDown start = run (runState go start) 31 | where go = get >>= (\n -> if n <= 0 then pure n else put (n-1) >> go) 32 | 33 | countDownRW :: Int -> (Int,Int) 34 | countDownRW start = run (runStateR go start) 35 | where go = ask >>= (\n -> if n <= 0 then pure n else tell (n-1) >> go) 36 | 37 | countDownMTL :: Int -> (Int,Int) 38 | countDownMTL = MTL.runState go 39 | where go = MTL.get >>= (\n -> if n <= 0 then pure n else MTL.put (n-1) >> go) 40 | 41 | -------------------------------------------------------------------------------- 42 | -- Exception + State -- 43 | -------------------------------------------------------------------------------- 44 | countDownExc :: Int -> Either String (Int,Int) 45 | countDownExc start = run $ runError (runState go start) 46 | where go = get >>= (\n -> if n <= (0 :: Int) then throwError "wat" else put (n-1) >> go) 47 | 48 | countDownExcMTL :: Int -> Either String (Int,Int) 49 | countDownExcMTL = MTL.runStateT go 50 | where go = MTL.get >>= (\n -> if n <= (0 :: Int) then MTL.throwError "wat" else MTL.put (n-1) >> go) 51 | 52 | -------------------------------------------------------------------------------- 53 | -- Freer: Interpreter -- 54 | -------------------------------------------------------------------------------- 55 | data Http out where 56 | Open :: String -> Http () 57 | Close :: Http () 58 | Post :: String -> Http String 59 | Get :: Http String 60 | 61 | open' :: Member Http r => String -> Eff r () 62 | open' = send . Open 63 | 64 | close' :: Member Http r => Eff r () 65 | close' = send Close 66 | 67 | post' :: Member Http r => String -> Eff r String 68 | post' = send . Post 69 | 70 | get' :: Member Http r => Eff r String 71 | get' = send Get 72 | 73 | runHttp :: Eff (Http ': e) b -> Eff e b 74 | runHttp (Val b) = pure b 75 | runHttp (E u q) = case decompose u of 76 | Right (Open _) -> runHttp (q `apply` ()) 77 | Right Close -> runHttp (q `apply` ()) 78 | Right (Post a) -> runHttp (q `apply` a) 79 | Right Get -> runHttp (q `apply` "") 80 | Left u' -> E u' $ tsingleton (runHttp . apply q) 81 | 82 | -------------------------------------------------------------------------------- 83 | -- Free: Interpreter -- 84 | -------------------------------------------------------------------------------- 85 | data FHttpT x 86 | = FOpen String x 87 | | FClose x 88 | | FPost String (String -> x) 89 | | FGet (String -> x) 90 | deriving Functor 91 | 92 | type FHttp = Free.Free FHttpT 93 | 94 | fopen' :: String -> FHttp () 95 | fopen' s = Free.liftF $ FOpen s () 96 | 97 | fclose' :: FHttp () 98 | fclose' = Free.liftF $ FClose () 99 | 100 | fpost' :: String -> FHttp String 101 | fpost' s = Free.liftF $ FPost s id 102 | 103 | fget' :: FHttp String 104 | fget' = Free.liftF $ FGet id 105 | 106 | runFHttp :: FHttp a -> Maybe a 107 | runFHttp (Free.Pure x) = pure x 108 | runFHttp (Free.Free (FOpen _ n)) = runFHttp n 109 | runFHttp (Free.Free (FClose n)) = runFHttp n 110 | runFHttp (Free.Free (FPost s n)) = pure s >>= runFHttp . n 111 | runFHttp (Free.Free (FGet n)) = pure "" >>= runFHttp . n 112 | 113 | -------------------------------------------------------------------------------- 114 | -- Benchmark Suite -- 115 | -------------------------------------------------------------------------------- 116 | prog :: Member Http r => Eff r () 117 | prog = open' "cats" >> get' >> post' "cats" >> close' 118 | 119 | prog' :: FHttp () 120 | prog' = fopen' "cats" >> fget' >> fpost' "cats" >> fclose' 121 | 122 | p :: Member Http r => Int -> Eff r () 123 | p count = open' "cats" >> replicateM_ count (get' >> post' "cats") >> close' 124 | 125 | p' :: Int -> FHttp () 126 | p' count = fopen' "cats" >> replicateM_ count (fget' >> fpost' "cats") >> fclose' 127 | 128 | main :: IO () 129 | main = 130 | defaultMain [ 131 | bgroup "State" [ 132 | bench "get" $ whnf oneGet 0 133 | ], 134 | bgroup "Countdown Bench" [ 135 | bench "effects.State" $ whnf countDown 10000 136 | , bench "effects.StateRW" $ whnf countDownRW 10000 137 | , bench "mtl.State" $ whnf countDownMTL 10000 138 | ], 139 | bgroup "Countdown+Except Bench" [ 140 | bench "effects.ExcState" $ whnf countDownExc 10000 141 | , bench "mtl.ExceptState" $ whnf countDownExcMTL 10000 142 | ], 143 | bgroup "HTTP Simple DSL" [ 144 | bench "effects" $ whnf (run . runHttp) prog 145 | , bench "effects" $ whnf runFHttp prog' 146 | 147 | , bench "effectsN" $ whnf (run . runHttp . p) 100000 148 | , bench "effectsN" $ whnf (runFHttp . p') 100000 149 | ] 150 | ] 151 | -------------------------------------------------------------------------------- /changelog.md: -------------------------------------------------------------------------------- 1 | # 0.3.2.0 (April 25, 2018) 2 | 3 | * Added an `interposeState` handler. 4 | 5 | # 0.3.1.0 (April 25, 2018) 6 | 7 | * Exported all the effect data constructors. 8 | * Too many other things have changed since 0.2.3.0 to list. 9 | 10 | # 0.2.3.0 (June 25, 2016) 11 | 12 | * Add GHC 8 support 13 | 14 | # 0.2.2.2 (Sep. 14, 2015) 15 | 16 | * Use local `data Nat` for `Data.Open.Union` 17 | * Using GHC.TypeLits lead to overlapping instances 18 | 19 | # 0.2.2.1 (Sep. 14, 2015) 20 | 21 | * Document ALL THE THINGS 22 | 23 | # 0.2.2.0 (Sep. 13, 2015) 24 | 25 | * Add bench suite 26 | 27 | # 0.2.1.0 (Sep. 13, 2015) 28 | 29 | * Add test suite 30 | 31 | # 0.2.0.2 (Sep. 12, 2015) 32 | 33 | * Clean up language extensions per file 34 | * Add Teletype DSL to the README 35 | 36 | # 0.2.0.1 (Sep. 12, 2015) 37 | 38 | * Add Teletype DSL example 39 | * Expose `send` in public interface 40 | 41 | # 0.2.0.0 (Sep. 12, 2015) 42 | 43 | * Implement NonDetEff 44 | * Separate Cut/Coroutine out from Internals 45 | * Partial implementation: won't compile yet 46 | * Extract remaining examples from Internal comments 47 | 48 | # 0.1.1.0 (Sep. 12, 2015) 49 | 50 | * Warnings clean up 51 | * Examples separated from primary implementation 52 | * Initial project documentation added 53 | 54 | # 0.1.0.0 (Sep. 12, 2015) 55 | 56 | * Initial release 57 | -------------------------------------------------------------------------------- /effects.cabal: -------------------------------------------------------------------------------- 1 | name: effects 2 | version: 0.3.2.0 3 | synopsis: Implementation of the Freer Monad 4 | license: BSD3 5 | license-file: LICENSE 6 | author: Josh Vera, Allele Dev 7 | maintainer: josh@joshvera.com 8 | copyright: Josh Vera, Allele Dev 2016 9 | homepage: https://github.com/joshvera/effects 10 | bug-reports: https://github.com/joshvera/effects/issues 11 | category: Control 12 | build-type: Simple 13 | cabal-version: >=1.18 14 | tested-with: GHC==7.10.2 15 | description: 16 | 17 | Effects is an implementation of "Freer Monads, More Extensible 18 | Effects". 19 | . 20 | The key features of Freer are: 21 | . 22 | * An efficient effect system for Haskell - as a library! 23 | . 24 | * Implementations for several common Haskell monad instances: 25 | . 26 | * Core components for defining your own Effects 27 | 28 | extra-source-files: 29 | README.md 30 | changelog.md 31 | CODE_OF_CONDUCT.md 32 | 33 | source-repository head 34 | type: git 35 | location: git clone https://github.com/joshvera/effects.git 36 | 37 | library 38 | exposed-modules: Control.Monad.Effect 39 | , Control.Monad.Effect.Coroutine 40 | , Control.Monad.Effect.Cut 41 | , Control.Monad.Effect.Exception 42 | , Control.Monad.Effect.Fail 43 | , Control.Monad.Effect.Fresh 44 | , Control.Monad.Effect.Internal 45 | , Control.Monad.Effect.NonDet 46 | , Control.Monad.Effect.Reader 47 | , Control.Monad.Effect.Resumable 48 | , Control.Monad.Effect.Resource 49 | , Control.Monad.Effect.State 50 | , Control.Monad.Effect.StateRW 51 | , Control.Monad.Effect.Trace 52 | , Control.Monad.Effect.Writer 53 | , Data.Union 54 | build-depends: base >=4.7 && <5 55 | , deepseq 56 | , type-aligned 57 | hs-source-dirs: src 58 | ghc-options: -Wall 59 | default-language: Haskell2010 60 | 61 | executable examples 62 | main-is: Main.hs 63 | other-modules: Common 64 | , Coroutine 65 | , Cut 66 | , Fresh 67 | , NonDet 68 | , Teletype 69 | , Trace 70 | build-depends: base >=4.7 && <5 71 | , effects 72 | hs-source-dirs: examples/src 73 | ghc-options: -Wall 74 | default-language: Haskell2010 75 | 76 | test-suite test 77 | default-language: Haskell2010 78 | type: exitcode-stdio-1.0 79 | hs-source-dirs: tests 80 | main-is: Tests.hs 81 | other-modules: Tests.Common 82 | , Tests.Coroutine 83 | , Tests.Exception 84 | , Tests.Fresh 85 | , Tests.NonDet 86 | , Tests.Reader 87 | , Tests.State 88 | , Tests.StateRW 89 | , Tests.Union 90 | build-depends: base 91 | , effects 92 | , tasty 93 | , tasty-hunit 94 | , tasty-quickcheck 95 | , QuickCheck 96 | 97 | ghc-options: -Wall 98 | 99 | benchmark core 100 | default-language: Haskell2010 101 | type: exitcode-stdio-1.0 102 | hs-source-dirs: bench 103 | main-is: Core.hs 104 | build-depends: base 105 | , effects 106 | , criterion 107 | , mtl 108 | , free 109 | 110 | ghc-options: -Wall -O2 111 | -------------------------------------------------------------------------------- /examples/src/Common.hs: -------------------------------------------------------------------------------- 1 | module Common where 2 | 3 | import Control.Applicative 4 | 5 | add :: Applicative f => f Int -> f Int -> f Int 6 | add = liftA2 (+) 7 | -------------------------------------------------------------------------------- /examples/src/Coroutine.hs: -------------------------------------------------------------------------------- 1 | module Coroutine where 2 | 3 | -- import Control.Monad.Effect.Coroutine 4 | 5 | {- 6 | 7 | -- First example of coroutines 8 | yieldInt :: (Member (Yield Int ()) r) => Int -> Eff r () 9 | yieldInt = yield 10 | 11 | th1 :: (Member (Yield Int ()) r) => Eff r () 12 | th1 = yieldInt 1 >> yieldInt 2 13 | 14 | 15 | c1 = runTrace (loop =<< runC th1) 16 | where loop (Y x k) = trace (show (x::Int)) >> k () >>= loop 17 | loop Done = trace "Done" 18 | {- 19 | 1 20 | 2 21 | Done 22 | -} 23 | 24 | -- Add dynamic variables 25 | -- The code is essentially the same as that in transf.hs (only added 26 | -- a type specialization on yield). The inferred signature is different though. 27 | -- Before it was 28 | -- th2 :: MonadReader Int m => CoT Int m () 29 | -- Now it is more general: 30 | th2 :: (Member (Yield Int ()) r, Member (Reader Int) r) => Eff r () 31 | th2 = ask >>= yieldInt >> (ask >>= yieldInt) 32 | 33 | 34 | -- Code is essentially the same as in transf.hs; no liftIO though 35 | c2 = runTrace $ runReader (loop =<< runC th2) (10::Int) 36 | where loop (Y x k) = trace (show (x::Int)) >> k () >>= loop 37 | loop Done = trace "Done" 38 | {- 39 | 10 40 | 10 41 | Done 42 | -} 43 | 44 | -- locally changing the dynamic environment for the suspension 45 | c21 = runTrace $ runReader (loop =<< runC th2) (10::Int) 46 | where loop (Y x k) = trace (show (x::Int)) >> local (+(1::Int)) (k ()) >>= loop 47 | loop Done = trace "Done" 48 | {- 49 | 10 50 | 11 51 | Done 52 | -} 53 | 54 | -- Real example, with two sorts of local rebinding 55 | th3 :: (Member (Yield Int ()) r, Member (Reader Int) r) => Eff r () 56 | th3 = ay >> ay >> local (+(10::Int)) (ay >> ay) 57 | where ay = ask >>= yieldInt 58 | 59 | c3 = runTrace $ runReader (loop =<< runC th3) (10::Int) 60 | where loop (Y x k) = trace (show (x::Int)) >> k () >>= loop 61 | loop Done = trace "Done" 62 | {- 63 | 10 64 | 10 65 | 20 66 | 20 67 | Done 68 | -} 69 | 70 | -- locally changing the dynamic environment for the suspension 71 | c31 = runTrace $ runReader (loop =<< runC th3) (10::Int) 72 | where loop (Y x k) = trace (show (x::Int)) >> local (+(1::Int)) (k ()) >>= loop 73 | loop Done = trace "Done" 74 | {- 75 | 10 76 | 11 77 | 21 78 | 21 79 | Done 80 | -} 81 | -- The result is exactly as expected and desired: the coroutine shares the 82 | -- dynamic environment with its parent; however, when the environment 83 | -- is locally rebound, it becomes private to coroutine. 84 | 85 | -- We now make explicit that the client computation, run by th4, 86 | -- is abstract. We abstract it out of th4 87 | c4 = runTrace $ runReader (loop =<< runC (th4 client)) (10::Int) 88 | where loop (Y x k) = trace (show (x::Int)) >> local (+(1::Int)) (k ()) >>= loop 89 | loop Done = trace "Done" 90 | 91 | -- cl, client, ay are monomorphic bindings 92 | th4 cl = cl >> local (+(10::Int)) cl 93 | client = ay >> ay 94 | ay = ask >>= yieldInt 95 | 96 | {- 97 | 10 98 | 11 99 | 21 100 | 21 101 | Done 102 | -} 103 | 104 | -- Even more dynamic example 105 | c5 = runTrace $ runReader (loop =<< runC (th client)) (10::Int) 106 | where loop (Y x k) = trace (show (x::Int)) >> local (\y->x+1) (k ()) >>= loop 107 | loop Done = trace "Done" 108 | 109 | -- cl, client, ay are monomorphic bindings 110 | client = ay >> ay >> ay 111 | ay = ask >>= yieldInt 112 | 113 | -- There is no polymorphic recursion here 114 | th cl = do 115 | cl 116 | v <- ask 117 | (if v > (20::Int) then id else local (+(5::Int))) cl 118 | if v > (20::Int) then return () else local (+(10::Int)) (th cl) 119 | {- 120 | 10 121 | 11 122 | 12 123 | 18 124 | 18 125 | 18 126 | 29 127 | 29 128 | 29 129 | 29 130 | 29 131 | 29 132 | Done 133 | -} 134 | 135 | -- And even more 136 | c7 = runTrace $ 137 | runReader (runReader (loop =<< runC (th client)) (10::Int)) (1000::Double) 138 | where loop (Y x k) = trace (show (x::Int)) >> 139 | local (\y->fromIntegral (x+1)::Double) (k ()) >>= loop 140 | loop Done = trace "Done" 141 | 142 | -- cl, client, ay are monomorphic bindings 143 | client = ay >> ay >> ay 144 | ay = ask >>= \x -> ask >>= 145 | \y -> yieldInt (x + round (y::Double)) 146 | 147 | -- There is no polymorphic recursion here 148 | th cl = do 149 | cl 150 | v <- ask 151 | (if v > (20::Int) then id else local (+(5::Int))) cl 152 | if v > (20::Int) then return () else local (+(10::Int)) (th cl) 153 | 154 | {- 155 | 1010 156 | 1021 157 | 1032 158 | 1048 159 | 1064 160 | 1080 161 | 1101 162 | 1122 163 | 1143 164 | 1169 165 | 1195 166 | 1221 167 | 1252 168 | 1283 169 | 1314 170 | 1345 171 | 1376 172 | 1407 173 | Done 174 | -} 175 | 176 | c7' = runTrace $ 177 | runReader (runReader (loop =<< runC (th client)) (10::Int)) (1000::Double) 178 | where loop (Y x k) = trace (show (x::Int)) >> 179 | local (\y->fromIntegral (x+1)::Double) (k ()) >>= loop 180 | loop Done = trace "Done" 181 | 182 | -- cl, client, ay are monomorphic bindings 183 | client = ay >> ay >> ay 184 | ay = ask >>= \x -> ask >>= 185 | \y -> yieldInt (x + round (y::Double)) 186 | 187 | -- There is no polymorphic recursion here 188 | th cl = do 189 | cl 190 | v <- ask 191 | (if v > (20::Int) then id else local (+(5::Double))) cl 192 | if v > (20::Int) then return () else local (+(10::Int)) (th cl) 193 | {- 194 | 1010 195 | 1021 196 | 1032 197 | 1048 198 | 1048 199 | 1048 200 | 1069 201 | 1090 202 | 1111 203 | 1137 204 | 1137 205 | 1137 206 | 1168 207 | 1199 208 | 1230 209 | 1261 210 | 1292 211 | 1323 212 | Done 213 | -} 214 | 215 | -} 216 | -------------------------------------------------------------------------------- /examples/src/Cut.hs: -------------------------------------------------------------------------------- 1 | module Cut where 2 | 3 | -- import Control.Monad.Effect.Cut 4 | 5 | 6 | {- 7 | -- The signature is inferred 8 | tcut1 :: (Member Choose r, Member (Exc CutFalse) r) => Eff r Int 9 | tcut1 = (return (1::Int) `mplus'` return 2) `mplus'` 10 | ((cutfalse `mplus'` return 4) `mplus'` 11 | return 5) 12 | 13 | tcut1r = run . makeChoice $ call tcut1 14 | -- [1,2] 15 | 16 | tcut2 = return (1::Int) `mplus'` 17 | call (return 2 `mplus'` (cutfalse `mplus'` return 3) `mplus'` 18 | return 4) 19 | `mplus'` return 5 20 | 21 | -- Here we see nested call. It poses no problems... 22 | tcut2r = run . makeChoice $ call tcut2 23 | -- [1,2,5] 24 | 25 | -- More nested calls 26 | tcut3 = call tcut1 `mplus'` call (tcut2 `mplus'` cutfalse) 27 | tcut3r = run . makeChoice $ call tcut3 28 | -- [1,2,1,2,5] 29 | 30 | tcut4 = call tcut1 `mplus'` (tcut2 `mplus'` cutfalse) 31 | tcut4r = run . makeChoice $ call tcut4 32 | -- [1,2,1,2,5] 33 | -} 34 | -------------------------------------------------------------------------------- /examples/src/Fresh.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE TypeApplications #-} 2 | module Fresh where 3 | 4 | import Control.Monad.Effect 5 | import Control.Monad.Effect.Fresh 6 | import Control.Monad.Effect.Trace 7 | 8 | traceFresh :: IO () 9 | traceFresh = runM @Eff . runPrintingTrace . runFresh 0 $ do 10 | n <- fresh 11 | trace $ "Fresh " ++ show n 12 | n' <- fresh 13 | trace $ "Fresh " ++ show n' 14 | n'' <- fresh 15 | trace $ "Fresh " ++ show n'' 16 | {- 17 | Fresh 0 18 | Fresh 1 19 | -} 20 | -------------------------------------------------------------------------------- /examples/src/Main.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE DataKinds #-} 2 | 3 | module Main where 4 | 5 | import Control.Monad.Effect 6 | import Teletype 7 | 8 | runner :: Eff '[Teletype] () 9 | runner = do 10 | x <- getLine' 11 | putStrLn' x 12 | y <- getLine' 13 | putStrLn' y 14 | 15 | main :: IO () 16 | main = do 17 | let xs = Teletype.runPure ["cat", "fish"] runner 18 | print xs 19 | Teletype.run runner 20 | -------------------------------------------------------------------------------- /examples/src/NonDet.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE FlexibleContexts #-} 2 | {-# LANGUAGE TypeOperators #-} 3 | module NonDet where 4 | 5 | import Control.Applicative 6 | import Control.Monad 7 | import Control.Monad.Effect 8 | import Control.Monad.Effect.NonDet 9 | 10 | ifte :: Member NonDet r 11 | => Eff r a -> (a -> Eff r b) -> Eff r b -> Eff r b 12 | ifte t th el = (t >>= th) <|> el 13 | 14 | testIfte :: Member NonDet r => Eff r Int 15 | testIfte = do 16 | n <- gen 17 | ifte (do d <- gen 18 | guard $ d < n && n `mod` d == 0) 19 | (const mzero) 20 | (return n) 21 | where gen = msum . fmap return $ [2..30] 22 | 23 | testIfteRun :: [Int] 24 | testIfteRun = run . runNonDetA $ testIfte 25 | -------------------------------------------------------------------------------- /examples/src/Teletype.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE GADTs #-} 2 | {-# LANGUAGE FlexibleContexts #-} 3 | {-# LANGUAGE TypeOperators #-} 4 | {-# LANGUAGE DataKinds, KindSignatures #-} 5 | module Teletype where 6 | 7 | import Control.Monad.Effect 8 | import Control.Monad.Effect.Internal as I 9 | import System.Exit hiding (ExitSuccess) 10 | 11 | data Teletype (m :: * -> *) s where 12 | PutStrLn :: String -> Teletype m () 13 | GetLine :: Teletype m String 14 | ExitSuccess :: Teletype m () 15 | 16 | -- Takes a string and returns a teletype effect. 17 | putStrLn' :: Member Teletype e => String -> Eff e () 18 | putStrLn' = send . PutStrLn 19 | 20 | -- Gets a line from a Teletype. 21 | getLine' :: Member Teletype e => Eff e String 22 | getLine' = send GetLine 23 | 24 | -- An exit success effect that returns (). 25 | exitSuccess' :: Member Teletype e => Eff e () 26 | exitSuccess' = send ExitSuccess 27 | 28 | -- Runs a Teletype effect b and returns IO b. 29 | run :: Eff '[Teletype] a -> IO a 30 | run (Return x) = pure x 31 | run (E u q) = case decompose u of 32 | Right (PutStrLn msg) -> putStrLn msg >> Teletype.run (apply q ()) 33 | Right GetLine -> getLine >>= \s -> Teletype.run (apply q s) 34 | Right ExitSuccess -> exitSuccess 35 | Left _ -> error "This cannot happen" 36 | 37 | -- Takes a list of strings and a teletype effect to run and 38 | -- returns the list of strings printed in that effect. 39 | runPure :: [String] -> Eff '[Teletype] a -> [String] 40 | runPure inputs req = reverse (go inputs req []) 41 | where go :: [String] -> Eff '[Teletype] w -> [String] -> [String] 42 | go _ (Return _) acc = acc 43 | go xs (E u q) acc = case xs of 44 | (x:xs') -> case decompose u of 45 | Right (PutStrLn msg) -> go (x:xs') (apply q ()) (msg:acc) 46 | Right GetLine -> go xs' (apply q x) acc 47 | Right ExitSuccess -> go xs' (Return ()) acc 48 | Left _ -> go xs' (Return ()) acc 49 | _ -> case decompose u of 50 | Right (PutStrLn msg) -> go xs (apply q ()) (msg:acc) 51 | _ -> go xs (Return ()) acc 52 | -------------------------------------------------------------------------------- /examples/src/Trace.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE FlexibleContexts #-} 2 | {-# LANGUAGE NoMonomorphismRestriction #-} 3 | {-# LANGUAGE TypeOperators #-} 4 | {-# LANGUAGE TypeApplications #-} 5 | module Trace where 6 | 7 | import Control.Monad.Effect 8 | import Control.Monad.Effect.Reader 9 | import Control.Monad.Effect.Trace 10 | 11 | import Common 12 | 13 | -- Higher-order effectful function 14 | -- The inferred type shows that the Trace affect is added to the effects 15 | -- of r 16 | mapMdebug:: (Show a, Member Trace r) => 17 | (a -> Eff r b) -> [a] -> Eff r [b] 18 | mapMdebug _ [] = return [] 19 | mapMdebug f (h:t) = do 20 | trace $ "mapMdebug: " ++ show h 21 | h' <- f h 22 | t' <- mapMdebug f t 23 | return (h':t') 24 | 25 | tMd :: IO [Int] 26 | tMd = runM @Eff . runPrintingTrace $ runReader (10::Int) (mapMdebug f [1..5]) 27 | where f x = ask `add` return x 28 | {- 29 | mapMdebug: 1 30 | mapMdebug: 2 31 | mapMdebug: 3 32 | mapMdebug: 4 33 | mapMdebug: 5 34 | [11,12,13,14,15] 35 | -} 36 | 37 | -- duplicate layers 38 | tdup :: IO () 39 | tdup = runM @Eff . runPrintingTrace $ runReader (10::Int) m 40 | where 41 | m = do 42 | runReader (20::Int) tr 43 | tr 44 | tr = do 45 | v <- ask 46 | trace $ "Asked: " ++ show (v::Int) 47 | {- 48 | Asked: 20 49 | Asked: 10 50 | -} 51 | -------------------------------------------------------------------------------- /src/Control/Monad/Effect.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE PatternSynonyms, TypeOperators #-} 2 | {-| 3 | Module : Control.Monad.Effect 4 | Description : Effects - an extensible effects library 5 | Copyright : Allele Dev 2015 6 | License : BSD-3 7 | Maintainer : allele.dev@gmail.com 8 | Stability : experimental 9 | Portability : POSIX 10 | 11 | -} 12 | module Control.Monad.Effect 13 | ( 14 | -- * Running and Sending Effects 15 | Eff 16 | , Effectful 17 | , raiseEff 18 | , lowerEff 19 | , run 20 | , runM 21 | , send 22 | -- * Effect handlers 23 | , pattern Effect 24 | , pattern Other 25 | , pattern Effect2_1 26 | , pattern Effect2_2 27 | , pattern Other2 28 | , liftStatefulHandler 29 | , liftHandler 30 | , Request(..) 31 | , interpret 32 | , reinterpret 33 | , reinterpret2 34 | -- * Local effect handlers 35 | , eavesdrop 36 | , interpose 37 | -- * Checking a List of Effects 38 | , Member 39 | -- * Effects 40 | , PureEffects 41 | , Effects 42 | , PureEffect(..) 43 | , defaultHandle 44 | , Effect(..) 45 | , Lift(..) 46 | , Exc 47 | , Fail 48 | , NonDet 49 | , Reader 50 | , Resumable 51 | , SomeExc(..) 52 | , State 53 | , Trace 54 | , Writer 55 | ) where 56 | 57 | import Control.Monad.Effect.Internal 58 | 59 | import Control.Monad.Effect.Exception (Exc) 60 | import Control.Monad.Effect.Fail (Fail) 61 | import Control.Monad.Effect.NonDet (NonDet) 62 | import Control.Monad.Effect.Reader (Reader) 63 | import Control.Monad.Effect.Resumable (Resumable, SomeExc(..)) 64 | import Control.Monad.Effect.State (State) 65 | import Control.Monad.Effect.Trace (Trace) 66 | import Control.Monad.Effect.Writer (Writer) 67 | -------------------------------------------------------------------------------- /src/Control/Monad/Effect/Coroutine.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE DeriveFunctor #-} 2 | {-# LANGUAGE FlexibleContexts #-} 3 | {-# LANGUAGE KindSignatures #-} 4 | {-# LANGUAGE TypeOperators #-} 5 | {-# LANGUAGE DataKinds #-} 6 | 7 | {-| 8 | Module : Control.Monad.Effect.Coroutine 9 | Description : Composable Coroutine effects 10 | Copyright : Allele Dev 2015 11 | License : BSD-3 12 | Maintainer : allele.dev@gmail.com 13 | Stability : broken 14 | Portability : POSIX 15 | 16 | An effect to compose functions with the ability to yield. 17 | 18 | Using as a 19 | starting point. 20 | 21 | -} 22 | module Control.Monad.Effect.Coroutine ( 23 | Yield(..), 24 | yield, 25 | Status(..), 26 | runC, 27 | runCoro 28 | ) where 29 | 30 | import Control.Monad ((<=<)) 31 | import Control.Monad.Effect.Internal 32 | 33 | -- | A type representing a yielding of control 34 | -- a: The current type 35 | -- b: The input to the continuation function 36 | -- v: The output of the continuation 37 | data Yield a b (m :: * -> *) v = Yield a (b -> v) 38 | deriving (Functor) 39 | 40 | -- | Lifts a value and a function into the Coroutine effect 41 | yield :: (Member (Yield a b) e, Effectful m) => a -> (b -> c) -> m e c 42 | yield x f = send (Yield x f) 43 | 44 | -- | 45 | -- Status of a thread: done or reporting the value of the type a and 46 | -- resuming with the value of type b 47 | data Status m (e :: [(* -> *) -> (* -> *)]) a b w = Done w | Continue a (b -> m e (Status m e a b w)) 48 | deriving (Functor) 49 | 50 | raiseStatus :: Effectful m => Status Eff e a b w -> Status m e a b w 51 | raiseStatus = status Done (\ a f -> Continue a (raiseEff . fmap raiseStatus . f)) 52 | 53 | status :: (w -> x) -> (a -> (b -> m e (Status m e a b w)) -> x) -> Status m e a b w -> x 54 | status f _ (Done w) = f w 55 | status _ g (Continue a f) = g a f 56 | 57 | joinStatus :: Effects effs => Status Eff effs a b (Eff (Yield a b : effs) x) -> Eff effs (Status Eff effs a b x) 58 | joinStatus = status runC (\ a f -> pure (Continue a (joinStatus <=< f))) 59 | 60 | -- | Launch a thread and report its status 61 | runC :: (Effectful m, Effects effs) => m (Yield a b ': effs) w -> m effs (Status m effs a b w) 62 | runC = raiseHandler (fmap raiseStatus . go) 63 | where go (Return a) = pure (Done a) 64 | go (Effect (Yield a f) k) = pure (Continue a (runC . k . f)) 65 | go (Other u k) = liftStatefulHandler (Done ()) joinStatus u k 66 | 67 | -- | Launch a thread and run it to completion using a helper function to provide new inputs. 68 | runCoro :: (Effectful m, Effects effs) => (a -> b) -> m (Yield a b ': effs) w -> m effs w 69 | runCoro f = raiseHandler (loop <=< runC) 70 | where loop (Done a) = pure a 71 | loop (Continue a k) = k (f a) >>= loop 72 | 73 | 74 | instance PureEffect (Yield a bs) 75 | instance Effect (Yield a bs) where 76 | handleState c dist (Request (Yield a f) k) = Request (Yield a f) (dist . (<$ c) . k) 77 | -------------------------------------------------------------------------------- /src/Control/Monad/Effect/Cut.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE FlexibleContexts #-} 2 | {-# LANGUAGE TypeOperators #-} 3 | {-# LANGUAGE DataKinds #-} 4 | 5 | {-| 6 | Module : Control.Monad.Effect.Cut 7 | Description : An implementation of logical Cut 8 | Copyright : Allele Dev 2015 9 | License : BSD-3 10 | Maintainer : allele.dev@gmail.com 11 | Stability : broken 12 | Portability : POSIX 13 | 14 | Composable handler for logical Cut effects. Implemented in terms of 15 | Exc effect. 16 | 17 | Using as a 18 | starting point. 19 | 20 | -} 21 | module Control.Monad.Effect.Cut ( 22 | CutFalse(..), 23 | cutFalse, 24 | -- call 25 | ) where 26 | 27 | -- import Control.Monad 28 | import Control.Monad.Effect.Exception 29 | import Control.Monad.Effect.Internal 30 | 31 | data CutFalse = CutFalse 32 | -- data Choose a b = Choose [a] b 33 | 34 | -- | Implementation of logical Cut using Exc effects. 35 | cutFalse :: (Member (Exc CutFalse) e, Effectful m) => m e a 36 | cutFalse = throwError CutFalse 37 | 38 | {- 39 | call :: Member (Exc CutFalse) r => Eff (Exc CutFalse ': r) a -> Eff r a 40 | call m = loop [] m where 41 | loop jq (Val x) = pure x `mplus` next jq -- (C2) 42 | loop jq (E u q) = case decompose u of 43 | Right (Exc CutFalse) -> mzero -- drop jq (F2) 44 | Left u -> check jq u 45 | 46 | check jq u | Just (Choose [] _) <- prj u = next jq -- (C1) 47 | check jq u | Just (Choose [x] k) <- prj u = loop jq (k x) -- (C3), optim 48 | check jq u | Just (Choose lst k) <- prj u = next $ map k lst ++ jq -- (C3) 49 | check jq u = send (\k -> fmap k u) >>= loop jq -- (C4) 50 | 51 | next [] = mzero 52 | next (h:t) = loop t h 53 | -} 54 | -------------------------------------------------------------------------------- /src/Control/Monad/Effect/Exception.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE DataKinds, FlexibleContexts, GADTs, KindSignatures, TypeApplications, TypeOperators #-} 2 | 3 | {-| 4 | Module : Control.Monad.Effect.Exception 5 | Description : An Exception effect and handler. 6 | Copyright : Allele Dev 2015 7 | License : BSD-3 8 | Maintainer : allele.dev@gmail.com 9 | Stability : experimental 10 | Portability : POSIX 11 | 12 | Composable handler for Exception effects. Communicates success/failure 13 | via an Either type. 14 | 15 | Using as a 16 | starting point. 17 | 18 | -} 19 | module Control.Monad.Effect.Exception 20 | ( Exc(..) 21 | -- * User-defined exception handling 22 | , throwError 23 | , runError 24 | , catchError 25 | , handleError 26 | -- * Handling impure/IO errors 27 | , rethrowing 28 | ) where 29 | 30 | import qualified Control.Exception as Exc 31 | import Control.Monad.IO.Class 32 | import Control.Monad.Effect.Internal 33 | 34 | -------------------------------------------------------------------------------- 35 | -- Exceptions -- 36 | -------------------------------------------------------------------------------- 37 | -- | Exceptions of the type 'exc'; no resumption 38 | data Exc exc (m :: * -> *) a where 39 | Throw :: exc -> Exc exc m a 40 | Catch :: m a -> (exc -> m a) -> Exc exc m a 41 | 42 | -- | Throws an error carrying information of type 'exc'. 43 | throwError :: (Member (Exc exc) e, Effectful m) => exc -> m e a 44 | throwError = send . Throw 45 | 46 | -- | Handler for exception effects 47 | -- If there are no exceptions thrown, returns Right If exceptions are 48 | -- thrown and not handled, returns Left, interrupting the execution of 49 | -- any other effect handlers. 50 | runError :: (Effectful m, Effects e) => m (Exc exc ': e) a -> m e (Either exc a) 51 | runError = raiseHandler go 52 | where go (Return a) = pure (Right a) 53 | go (Effect (Throw e) _) = pure (Left e) 54 | go (Effect (Catch a h) k) = do 55 | a' <- runError a 56 | case a' of 57 | Left e -> runError (h e >>= k) 58 | Right a'' -> runError (k a'') 59 | go (Other u k) = liftStatefulHandler (Right ()) (either (pure . Left) runError) u k 60 | 61 | -- | A catcher for Exceptions. Handlers are allowed to rethrow 62 | -- exceptions. 63 | catchError :: (Member (Exc exc) e, Effectful m) => 64 | m e a -> (exc -> m e a) -> m e a 65 | catchError a h = send (Catch (lowerEff a) (lowerEff . h)) 66 | 67 | -- | 'catchError', but with its arguments in the opposite order. Useful 68 | -- in situations where the code for the handler is shorter, or when 69 | -- composing chains of handlers together. 70 | handleError :: (Member (Exc exc) e, Effectful m) => (exc -> m e a) -> m e a -> m e a 71 | handleError = flip catchError 72 | 73 | 74 | instance PureEffect (Exc exc) 75 | instance Effect (Exc exc) where 76 | handleState c dist (Request (Throw exc) k) = Request (Throw exc) (dist . (<$ c) . k) 77 | handleState c dist (Request (Catch a h) k) = Request (Catch (dist (a <$ c)) (dist . (<$ c) . h)) (dist . fmap k) 78 | 79 | -- | Lift an 'IO' action into 'Eff', catching and rethrowing any exceptions it throws into an 'Exc' effect. 80 | -- If you need more granular control over the types of exceptions caught, use 'catchIO' and rethrow in the handler. 81 | rethrowing :: ( Member (Exc Exc.SomeException) e 82 | , Member (Lift IO) e 83 | , Effectful m 84 | ) 85 | => IO a 86 | -> m e a 87 | rethrowing m = raiseEff (liftIO (Exc.try m) >>= either (throwError . Exc.toException @Exc.SomeException) pure) 88 | -------------------------------------------------------------------------------- /src/Control/Monad/Effect/Fail.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE DataKinds, FlexibleContexts, TypeOperators #-} 2 | module Control.Monad.Effect.Fail 3 | ( Fail(..) 4 | , runFail 5 | , MonadFail(..) 6 | ) where 7 | 8 | import Control.Monad.Effect.Internal 9 | import Control.Monad.Fail 10 | 11 | runFail :: (Effectful m, Effects effs) => m (Fail ': effs) a -> m effs (Either String a) 12 | runFail = raiseHandler go 13 | where go (Return a) = pure (Right a) 14 | go (Effect (Fail s) _) = pure (Left s) 15 | go (Other u k) = liftStatefulHandler (Right ()) (either (pure . Left) runFail) u k 16 | -------------------------------------------------------------------------------- /src/Control/Monad/Effect/Fresh.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE TypeOperators #-} 2 | {-# LANGUAGE DataKinds, KindSignatures #-} 3 | {-# LANGUAGE FlexibleContexts #-} 4 | {-# LANGUAGE GADTs #-} 5 | 6 | {-| 7 | Module : Control.Monad.Effect.Fresh 8 | Description : Generation of fresh integers as an effect. 9 | Copyright : Allele Dev 2015 10 | License : BSD-3 11 | Maintainer : allele.dev@gmail.com 12 | Stability : broken 13 | Portability : POSIX 14 | 15 | Composable handler for Fresh effects. This is likely to be of use when 16 | implementing De Bruijn naming/scopes. 17 | 18 | Using as a 19 | starting point. 20 | 21 | -} 22 | module Control.Monad.Effect.Fresh 23 | ( Fresh(..) 24 | , fresh 25 | , resetFresh 26 | , runFresh 27 | ) where 28 | 29 | import Control.Monad.Effect.Internal 30 | 31 | -------------------------------------------------------------------------------- 32 | -- Fresh -- 33 | -------------------------------------------------------------------------------- 34 | -- | Fresh effect model 35 | data Fresh (m :: * -> *) v where 36 | Fresh :: Fresh m Int 37 | Reset :: Int -> m a -> Fresh m a 38 | 39 | -- | Request a fresh effect 40 | fresh :: (Member Fresh e, Effectful m) => m e Int 41 | fresh = send Fresh 42 | 43 | resetFresh :: (Effectful m, Member Fresh effects) => Int -> m effects a -> m effects a 44 | resetFresh i a = send (Reset i (lowerEff a)) 45 | 46 | -- | Handler for Fresh effects, with an Int for a starting value 47 | runFresh :: (Effectful m, Effects e) => Int -> m (Fresh ': e) a -> m e a 48 | runFresh i = raiseHandler (fmap snd . go i) 49 | where go :: Effects e => Int -> Eff (Fresh ': e) a -> Eff e (Int, a) 50 | go s (Return a) = pure (s, a) 51 | go s (Effect Fresh k) = go (succ s) (k s) 52 | go s (Effect (Reset s' a) k) = go s' a >>= go s . k . snd 53 | go s (Other u k) = liftStatefulHandler (s, ()) (uncurry go) u k 54 | 55 | 56 | instance PureEffect Fresh 57 | instance Effect Fresh where 58 | handleState c dist (Request Fresh k) = Request Fresh (dist . (<$ c) . k) 59 | handleState c dist (Request (Reset i a) k) = Request (Reset i (dist (a <$ c))) (dist . fmap k) 60 | -------------------------------------------------------------------------------- /src/Control/Monad/Effect/Internal.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE ConstraintKinds, DataKinds, DefaultSignatures, DeriveFoldable, DeriveFunctor, DeriveTraversable, FlexibleContexts, FlexibleInstances, GADTs, GeneralizedNewtypeDeriving, KindSignatures, PatternSynonyms, RankNTypes, TypeApplications, TypeOperators, UndecidableInstances, ViewPatterns #-} 2 | module Control.Monad.Effect.Internal ( 3 | -- * Constructing and Sending Effects 4 | Eff(..) 5 | , send 6 | , NonDet(..) 7 | , Fail(..) 8 | , Lift(..) 9 | -- * Handling effects 10 | , pattern Effect 11 | , pattern Other 12 | , pattern Effect2_1 13 | , pattern Effect2_2 14 | , pattern Other2 15 | , Request(..) 16 | , decomposeEff 17 | , PureEffects 18 | , Effects 19 | , PureEffect(..) 20 | , defaultHandle 21 | , Effect(..) 22 | , liftStatefulHandler 23 | , liftHandler 24 | , Effectful(..) 25 | , raiseHandler 26 | , lowerHandler 27 | -- * Decomposing Unions 28 | , Member 29 | , decompose 30 | , inj 31 | , prj 32 | -- * Constructing and Decomposing Queues of Effects 33 | , Queue 34 | , tsingleton 35 | , Arrow(..) 36 | , Union 37 | -- * Composing and Applying Effects 38 | , apply 39 | , (<<<) 40 | , (>>>) 41 | -- * Running Effects 42 | , run 43 | , runM 44 | -- * Local effect handlers 45 | , eavesdrop 46 | , interpose 47 | -- * Effect handlers 48 | , interpret 49 | , reinterpret 50 | , reinterpret2 51 | ) where 52 | 53 | import Control.Applicative (Alternative (..)) 54 | import Control.Monad (MonadPlus (..)) 55 | import Control.Monad.Fail (MonadFail (..)) 56 | import Control.Monad.IO.Class (MonadIO (..)) 57 | import Data.Coerce 58 | import Data.Functor.Identity 59 | import Data.TASequence.BinaryTree 60 | import Data.Union 61 | 62 | -- | An effectful computation that returns 'b' and sends a list of 'effects'. 63 | data Eff effects b 64 | -- | Done with the value of type `b`. 65 | = Return b 66 | -- | Send an union of 'effects' and 'eff a' to handle, and a queues of effects to apply from 'a' to 'b'. 67 | | forall a. E (Union effects (Eff effects) a) (Queue (Eff effects) a b) 68 | 69 | -- | The topmost effect, and the continuation following it. 70 | pattern Effect :: effect (Eff (effect ': effects)) b -> (b -> Eff (effect ': effects) a) -> Eff (effect ': effects) a 71 | pattern Effect eff k <- (decomposeEff -> Right (Request (decompose -> Right eff) k)) 72 | 73 | -- | Another effect in the 'Union', and the continuation following it. 74 | pattern Other :: Union effects (Eff (effect ': effects)) b -> (b -> Eff (effect ': effects) a) -> Eff (effect ': effects) a 75 | pattern Other u k <- (decomposeEff -> Right (Request (decompose -> Left u) k)) 76 | {-# COMPLETE Return, Effect, Other #-} 77 | 78 | -- | The first of the topmost two effects in the 'Union', and the continuation following it. 79 | pattern Effect2_1 :: effect1 (Eff (effect1 ': effect2 ': effects)) b -> (b -> Eff (effect1 ': effect2 ': effects) a) -> Eff (effect1 ': effect2 ': effects) a 80 | pattern Effect2_1 eff k <- (decomposeEff -> Right (Request (decompose -> Right eff) k)) 81 | 82 | -- | The second of the topmost two effects in the 'Union', and the continuation following it. 83 | pattern Effect2_2 :: effect2 (Eff (effect1 ': effect2 ': effects)) b -> (b -> Eff (effect1 ': effect2 ': effects) a) -> Eff (effect1 ': effect2 ': effects) a 84 | pattern Effect2_2 eff k <- (decomposeEff -> Right (Request (decompose -> Left (decompose -> Right eff)) k)) 85 | 86 | -- | Another effect in the 'Union', and the continuation following it. 87 | pattern Other2 :: Union effects (Eff (effect1 ': effect2 ': effects)) b -> (b -> Eff (effect1 ': effect2 ': effects) a) -> Eff (effect1 ': effect2 ': effects) a 88 | pattern Other2 u k <- (decomposeEff -> Right (Request (decompose -> Left (decompose -> Left u)) k)) 89 | {-# COMPLETE Return, Effect2_1, Effect2_2, Other2 #-} 90 | 91 | 92 | -- | A queue of effects to apply from 'a' to 'b'. 93 | type Queue m = BinaryTree (Arrow m) 94 | 95 | -- | An effectful function from 'a' to 'b' 96 | -- that also performs a list of 'effects'. 97 | newtype Arrow m a b = Arrow { runArrow :: a -> m b } 98 | 99 | 100 | data Request effect m a = forall b . Request (effect m b) (b -> m a) 101 | 102 | instance Functor m => Functor (Request effect m) where 103 | fmap f (Request eff k) = Request eff (fmap f . k) 104 | {-# INLINE fmap #-} 105 | 106 | requestMap :: (forall x . effect m x -> effect' m x) -> Request effect m a -> Request effect' m a 107 | requestMap f (Request effect q) = Request (f effect) q 108 | {-# INLINE requestMap #-} 109 | 110 | fromRequest :: Request (Union effects) (Eff effects) a -> Eff effects a 111 | fromRequest (Request u k) = E u (tsingleton (Arrow k)) 112 | {-# INLINE fromRequest #-} 113 | 114 | -- | Decompose an 'Eff' into 'Either' a value or a 'Request' for one of a 'Union' of effects. 115 | decomposeEff :: Eff effects a -> Either a (Request (Union effects) (Eff effects) a) 116 | decomposeEff (Return a) = Left a 117 | decomposeEff (E u q) = Right (Request u (apply q)) 118 | {-# INLINE decomposeEff #-} 119 | 120 | class PureEffect effect where 121 | handle :: (Functor m, Functor n) 122 | => (forall x . m x -> n x) 123 | -> Request effect m a 124 | -> Request effect n a 125 | default handle :: (Effect effect, Functor m, Functor n) => (forall x . m x -> n x) -> Request effect m a -> Request effect n a 126 | handle = defaultHandle 127 | {-# INLINE handle #-} 128 | 129 | defaultHandle :: (Effect effect, Functor m, Functor n) 130 | => (forall x . m x -> n x) 131 | -> Request effect m a 132 | -> Request effect n a 133 | defaultHandle handler (Request u k) = runIdentity <$> handleState (Identity ()) (fmap Identity . handler . runIdentity) (Request u k) 134 | {-# INLINE defaultHandle #-} 135 | 136 | -- | Effects are higher-order (may themselves contain effectful actions), and as such must be able to thread an effect handler (structured as a distributive law) through themselves. 137 | class PureEffect effect => Effect effect where 138 | -- | Lift some initial state and a handler for some effect through another effect. 139 | -- 140 | -- First-order effects (ones not using the @m@ parameter) have relatively simple definitions, more or less just pushing the distributive law through the continuation. Higher-order effects (like @Reader@’s @Local@ constructor) must additionally apply the handler to their scoped actions. 141 | handleState :: (Functor c, Functor m, Functor n) 142 | => c () 143 | -> (forall x . c (m x) -> n (c x)) 144 | -> Request effect m a 145 | -> Request effect n (c a) 146 | 147 | -- | Lift a stateful effect handler through other effects in the 'Union'. 148 | -- 149 | -- Useful when defining effect handlers which maintain some state (such as @runState@) or which must return values in some carrier functor encapsulating the effects (such as @runError@). 150 | liftStatefulHandler :: (Functor c, Effects effects') => c () -> (forall x . c (Eff effects x) -> Eff effects' (c x)) -> Union effects' (Eff effects) b -> (b -> Eff effects a) -> Eff effects' (c a) 151 | liftStatefulHandler c handler u k = fromRequest (handleState c handler (Request u k)) 152 | {-# INLINE liftStatefulHandler #-} 153 | 154 | -- | Lift a pure effect handler through other effects in the 'Union'. 155 | -- 156 | -- Useful when defining pure effect handlers (such as @runReader@). 157 | liftHandler :: (Effectful m, PureEffects effects') => (forall x . m effects x -> m effects' x) -> Union effects' (Eff effects) b -> (b -> m effects a) -> m effects' a 158 | liftHandler handler u k = raiseEff (fromRequest (handle (lowerHandler handler) (Request u (lowerEff . k)))) 159 | {-# INLINE liftHandler #-} 160 | 161 | instance ForAll PureEffect effects => PureEffect (Union effects) where 162 | handle handler (Request u k) = forAll @PureEffect (\ reinj eff -> reinj `requestMap` handle handler (Request eff k)) u 163 | {-# INLINE handle #-} 164 | 165 | instance (ForAll PureEffect effects, ForAll Effect effects) => Effect (Union effects) where 166 | handleState state handler (Request u k) = forAll @Effect (\ reinj eff -> reinj `requestMap` handleState state handler (Request eff k)) u 167 | {-# INLINE handleState #-} 168 | 169 | 170 | -- | Require a 'PureEffect' instance for each effect in the list. 171 | type PureEffects effects = ForAll PureEffect effects 172 | 173 | -- | Require an 'Effect' instance for each effect in the list. 174 | type Effects effects = (ForAll PureEffect effects, ForAll Effect effects) 175 | 176 | 177 | -- | Types wrapping 'Eff' actions. 178 | -- 179 | -- Most instances of 'Effectful' will be derived using @-XGeneralizedNewtypeDeriving@, with these ultimately bottoming out on the instance for 'Eff' (for which 'raise' and 'lower' are simply the identity). Because of this, types can be nested arbitrarily deeply and still call 'raiseEff'/'lowerEff' just once to get at the (ultimately) underlying 'Eff'. 180 | class Effectful m where 181 | -- | Raise an action in 'Eff' into an action in @m@. 182 | raiseEff :: Eff effects a -> m effects a 183 | 184 | -- | Lower an action in @m@ into an action in 'Eff'. 185 | lowerEff :: m effects a -> Eff effects a 186 | 187 | instance Effectful Eff where 188 | raiseEff = coerce 189 | {-# INLINE raiseEff #-} 190 | 191 | lowerEff = coerce 192 | {-# INLINE lowerEff #-} 193 | 194 | -- | Raise a handler on 'Eff' to a handler on some 'Effectful' @m@. 195 | raiseHandler :: Effectful m => (Eff effectsA a -> Eff effectsB b) -> m effectsA a -> m effectsB b 196 | raiseHandler handler = raiseEff . handler . lowerEff 197 | {-# INLINE raiseHandler #-} 198 | 199 | -- | Lower a handler on some 'Effectful' @m@ to a handler on 'Eff'. 200 | lowerHandler :: Effectful m => (m effectsA a -> m effectsB b) -> Eff effectsA a -> Eff effectsB b 201 | lowerHandler handler = lowerEff . handler . raiseEff 202 | {-# INLINE lowerHandler #-} 203 | 204 | 205 | -- * Composing and Applying Effects 206 | 207 | -- | Returns an effect by applying a given value to a queue of effects. 208 | apply :: Queue (Eff effects) a b -> a -> Eff effects b 209 | apply q' x = 210 | case tviewl q' of 211 | TAEmptyL -> pure x 212 | k :< t -> case runArrow k x of 213 | Return y -> t `apply` y 214 | E u q -> E u (q >< t) 215 | {-# INLINE apply #-} 216 | 217 | -- | Compose queues left to right. 218 | (>>>) :: Queue (Eff effects) a b 219 | -> (Eff effects b -> Eff effects' c) -- ^ A function to compose. 220 | -> (a -> Eff effects' c) 221 | (>>>) queue f = f . apply queue 222 | {-# INLINE (>>>) #-} 223 | 224 | -- | Compose queues right to left. 225 | (<<<) :: (Eff effects b -> Eff effects' c) -- ^ A function to compose. 226 | -> Queue (Eff effects) a b 227 | -> (a -> Eff effects' c) 228 | (<<<) f queue = f . apply queue 229 | {-# INLINE (<<<) #-} 230 | 231 | -- * Sending and Running Effects 232 | 233 | -- | Send an effect and wait for a reply. 234 | send :: (Member eff e, Effectful m) => eff (Eff e) b -> m e b 235 | send t = raiseEff (E (inj t) (tsingleton (Arrow Return))) 236 | {-# INLINE [2] send #-} 237 | {-# RULES 238 | "send/bind" [~3] forall t k. send t >>= k = E (inj t) (tsingleton (Arrow k)) 239 | #-} 240 | 241 | -- | Runs an effect whose effects has been consumed. 242 | -- 243 | -- Typically composed as follows: 244 | -- 245 | -- @ 246 | -- run . runEff1 eff1Arg . runEff2 eff2Arg1 eff2Arg2 (program) 247 | -- @ 248 | run :: Effectful m => m '[] b -> b 249 | run m = case lowerEff m of 250 | Return x -> x 251 | _ -> error "Internal:run - This (E) should never happen" 252 | -- the other case is unreachable since Union [] a cannot be 253 | -- constructed. Therefore, run is a total function if its argument 254 | -- terminates. 255 | 256 | -- | Runs an effect for which all but one Monad effect has been consumed, 257 | -- and returns an 'm a'. 258 | -- 259 | -- This is useful for plugging in traditional transformer stacks. 260 | runM :: (Effectful m, Monad m1) => m '[Lift m1] a -> m1 a 261 | runM m = case lowerEff m of 262 | Return x -> pure x 263 | E u q -> unLift (strengthen u) >>= runM . apply q 264 | {-# SPECIALIZE runM :: Eff '[Lift IO] a -> IO a #-} 265 | 266 | 267 | -- * Local handlers 268 | 269 | -- | Listen for an effect, and take some action before re-sending it. 270 | eavesdrop :: (Member eff effects, Effectful m, PureEffects effects) 271 | => (forall v. eff (Eff effects) v -> m effects ()) 272 | -> m effects a 273 | -> m effects a 274 | eavesdrop listener = raiseHandler loop 275 | where loop (Return a) = pure a 276 | loop (E u q) = case prj u of 277 | Just eff -> lowerEff (listener eff) >> send eff >>= (q >>> loop) 278 | _ -> liftHandler (eavesdrop (lowerEff . listener)) u (apply q) 279 | {-# INLINE eavesdrop #-} 280 | 281 | -- | Intercept the request and possibly reply to it, but leave it 282 | -- unhandled 283 | interpose :: (Member eff e, Effectful m, PureEffects e) 284 | => (forall v. eff (Eff e) v -> m e v) 285 | -> m e a 286 | -> m e a 287 | interpose handler = raiseHandler loop 288 | where loop (Return a) = pure a 289 | loop (E u q) = case prj u of 290 | Just eff -> lowerEff (handler eff) >>= k 291 | _ -> liftHandler (interpose (lowerEff . handler)) u (apply q) 292 | where k = q >>> loop 293 | {-# INLINE interpose #-} 294 | 295 | 296 | -- * Effect handlers 297 | 298 | -- | Handle the topmost effect by interpreting it into the underlying effects. 299 | interpret :: (Effectful m, PureEffects effs) 300 | => (forall v. eff (Eff (eff ': effs)) v -> m effs v) 301 | -> m (eff ': effs) a 302 | -> m effs a 303 | interpret bind = raiseHandler loop 304 | where loop (Return a) = pure a 305 | loop (Effect eff k) = lowerEff (bind eff) >>= loop . k 306 | loop (Other u k) = liftHandler (interpret (lowerEff . bind)) u k 307 | {-# INLINE interpret #-} 308 | 309 | 310 | -- | Interpret an effect by replacing it with another effect. 311 | reinterpret :: (Effectful m, PureEffects (newEffect ': effs)) 312 | => (forall v. effect (Eff (effect ': effs)) v -> m (newEffect ': effs) v) 313 | -> m (effect ': effs) a 314 | -> m (newEffect ': effs) a 315 | reinterpret bind = raiseHandler loop 316 | where loop (Return a) = pure a 317 | loop (Effect eff k) = lowerEff (bind eff) >>= loop . k 318 | loop (Other u k) = liftHandler (reinterpret (lowerEff . bind)) (weaken u) k 319 | {-# INLINE reinterpret #-} 320 | 321 | -- | Interpret an effect by replacing it with two new effects. 322 | reinterpret2 :: (Effectful m, PureEffects (newEffect1 ': newEffect2 ': effs)) 323 | => (forall v. effect (Eff (effect ': effs)) v -> m (newEffect1 ': newEffect2 ': effs) v) 324 | -> m (effect ': effs) a 325 | -> m (newEffect1 ': newEffect2 ': effs) a 326 | reinterpret2 bind = raiseHandler loop 327 | where loop (Return a) = pure a 328 | loop (Effect eff k) = lowerEff (bind eff) >>= loop . k 329 | loop (Other u k) = liftHandler (reinterpret2 (lowerEff . bind)) (weaken (weaken u)) k 330 | {-# INLINE reinterpret2 #-} 331 | 332 | 333 | -- * Effect Instances 334 | 335 | instance Functor (Eff e) where 336 | fmap f (Return x) = Return (f x) 337 | fmap f (E u q) = E u (q |> Arrow (Return . f)) 338 | {-# INLINE fmap #-} 339 | 340 | instance Applicative (Eff e) where 341 | pure = Return 342 | {-# INLINE pure #-} 343 | 344 | Return f <*> Return x = Return $ f x 345 | Return f <*> E u q = E u (q |> Arrow (Return . f)) 346 | E u q <*> m = E u (q |> Arrow (`fmap` m)) 347 | {-# INLINE (<*>) #-} 348 | 349 | instance Monad (Eff e) where 350 | return = Return 351 | {-# INLINE return #-} 352 | 353 | Return x >>= k = k x 354 | E u q >>= k = E u (q |> Arrow k) 355 | {-# INLINE [2] (>>=) #-} 356 | 357 | instance Member (Lift IO) e => MonadIO (Eff e) where 358 | liftIO = send . Lift 359 | {-# INLINE liftIO #-} 360 | 361 | 362 | -- | Lift a first-order effect (e.g. a 'Monad' like 'IO') into an 'Eff'. 363 | newtype Lift effect (m :: * -> *) a = Lift { unLift :: effect a } 364 | deriving (Eq, Foldable, Functor, Ord, Show, Traversable) 365 | 366 | instance PureEffect (Lift effect) 367 | instance Effect (Lift effect) where 368 | handleState c dist (Request (Lift op) k) = Request (Lift op) (dist . (<$ c) . k) 369 | 370 | 371 | -- | A data type for representing nondeterminstic choice 372 | data NonDet (m :: * -> *) a where 373 | MZero :: NonDet m a 374 | MPlus :: NonDet m Bool 375 | 376 | instance Member NonDet e => Alternative (Eff e) where 377 | empty = mzero 378 | (<|>) = mplus 379 | 380 | instance Member NonDet a => MonadPlus (Eff a) where 381 | mzero = send MZero 382 | mplus m1 m2 = send MPlus >>= \x -> if x then m1 else m2 383 | 384 | instance PureEffect NonDet 385 | instance Effect NonDet where 386 | handleState c dist (Request MZero k) = Request MZero (dist . (<$ c) . k) 387 | handleState c dist (Request MPlus k) = Request MPlus (dist . (<$ c) . k) 388 | 389 | 390 | -- | An effect representing failure. 391 | newtype Fail (m :: * -> *) a = Fail { failMessage :: String } 392 | 393 | instance Member Fail fs => MonadFail (Eff fs) where 394 | fail = send . Fail 395 | 396 | instance PureEffect Fail 397 | instance Effect Fail where 398 | handleState c dist (Request (Fail s) k) = Request (Fail s) (dist . (<$ c) . k) 399 | -------------------------------------------------------------------------------- /src/Control/Monad/Effect/NonDet.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE DataKinds, FlexibleContexts, GADTs, TypeApplications, TypeOperators, UndecidableInstances #-} 2 | 3 | {-| 4 | Module : Control.Monad.Effect.NonDet 5 | Description : Nondeterministic Choice effects 6 | Copyright : Allele Dev 2015 7 | License : BSD-3 8 | Maintainer : allele.dev@gmail.com 9 | Stability : experimental 10 | Portability : POSIX 11 | -} 12 | 13 | 14 | module Control.Monad.Effect.NonDet ( 15 | NonDet(..), 16 | runNonDetM, 17 | gatherM, 18 | gather, 19 | runNonDetA, 20 | runNonDet, 21 | msplit 22 | ) where 23 | 24 | import Control.Applicative 25 | import Control.Monad 26 | import Control.Monad.Effect.Internal 27 | import Data.Foldable (asum) 28 | 29 | -------------------------------------------------------------------------------- 30 | -- Nondeterministic Choice -- 31 | -------------------------------------------------------------------------------- 32 | 33 | runNonDetM :: (Monoid b, Effectful m, Effects e) 34 | => (a -> b) 35 | -> m (NonDet ': e) a 36 | -> m e b 37 | runNonDetM unit = raiseHandler (fmap (foldMap unit) . runNonDet) 38 | 39 | gatherM :: (Monoid b, Member NonDet e, Effectful m, Effects e) 40 | => (a -> b) -- ^ A function constructing a 'Monoid'al value from a single computed result. This might typically be @unit@ (for @Reducer@s), 'pure' (for 'Applicative's), or some similar singleton constructor. 41 | -> m e a -- ^ The computation to run locally-nondeterministically. 42 | -> m e b 43 | gatherM unit = raiseHandler (fmap (foldMap unit) . gather) 44 | 45 | gather :: (Member NonDet e, Effectful m, Effects e) 46 | => m e a 47 | -> m e [a] 48 | gather = raiseHandler go 49 | where go (Return a) = pure [a] 50 | go (E u q) = case prj u of 51 | Just MZero -> pure [] 52 | Just MPlus -> liftA2 (++) (gather (apply q True)) (gather (apply q False)) 53 | Nothing -> liftStatefulHandler [()] (fmap join . traverse gather) u (apply q) 54 | 55 | -- | A handler for nondeterminstic effects 56 | runNonDetA :: (Alternative f, Effectful m, Effects e) 57 | => m (NonDet ': e) a 58 | -> m e (f a) 59 | runNonDetA = raiseHandler (fmap (asum . map pure) . runNonDet) 60 | 61 | -- | A handler for nondeterminstic effects 62 | runNonDet :: (Effectful m, Effects e) 63 | => m (NonDet ': e) a 64 | -> m e [a] 65 | runNonDet = raiseHandler go 66 | where go (Return a) = pure [a] 67 | go (Effect MZero _) = pure [] 68 | go (Effect MPlus k) = liftA2 (++) (runNonDet (k True)) (runNonDet (k False)) 69 | go (Other u k) = liftStatefulHandler [()] (fmap join . traverse runNonDet) u k 70 | 71 | -- FIXME: It would probably be more efficient to define these in terms of a binary tree rather than a list. 72 | 73 | msplit :: (Member NonDet e, Effectful m) 74 | => m e a -> m e (Maybe (a, m e a)) 75 | msplit = raiseHandler (fmap (fmap (fmap raiseEff)) . loop []) 76 | where loop jq (Return x) = pure (Just (x, msum jq)) 77 | loop jq (E u q) = 78 | case prj u of 79 | Just MZero -> 80 | case jq of 81 | [] -> pure Nothing 82 | (j:jq') -> loop jq' j 83 | Just MPlus -> loop (q `apply` False : jq) (q `apply` True) 84 | Nothing -> E u (tsingleton (Arrow k)) 85 | where k = q >>> loop jq 86 | -------------------------------------------------------------------------------- /src/Control/Monad/Effect/Reader.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE TypeOperators #-} 2 | {-# LANGUAGE GADTs #-} 3 | {-# LANGUAGE FlexibleContexts #-} 4 | {-# LANGUAGE DataKinds, KindSignatures #-} 5 | {-# LANGUAGE ScopedTypeVariables #-} 6 | 7 | {-| 8 | Module : Control.Monad.Effect.Reader 9 | Description : Reader effects for computations that carry an environment 10 | Copyright : Allele Dev 2015 11 | License : BSD-3 12 | Maintainer : allele.dev@gmail.com 13 | Stability : experimental 14 | Portability : POSIX 15 | 16 | Composable handler for Reader effects. Handy for encapsulating an 17 | environment with immutable state for interpreters. 18 | 19 | Using as a 20 | starting point. 21 | 22 | -} 23 | module Control.Monad.Effect.Reader ( 24 | Reader(..), 25 | 26 | ask, 27 | asks, 28 | runReader, 29 | local 30 | -- * Example 1: Simple Reader Usage 31 | -- $simpleReaderExample 32 | 33 | -- * Example 2: Modifying Reader Content With @local@ 34 | -- $localExample 35 | 36 | ) where 37 | 38 | import Control.Monad.Effect.Internal 39 | 40 | -- | 41 | data Reader v (m :: * -> *) a where 42 | Reader :: Reader a m a 43 | Local :: (v -> v) -> m a -> Reader v m a 44 | 45 | -- | Request a value for the environment 46 | ask :: (Member (Reader v) e, Effectful m) => m e v 47 | ask = send Reader 48 | 49 | -- | Request a value from the environment and applys as function 50 | asks :: (Member (Reader v) e, Effectful m) => (v -> a) -> m e a 51 | asks f = raiseEff (f <$> ask) 52 | 53 | -- | Handler for reader effects 54 | runReader :: (Effectful m, PureEffects e) => v -> m (Reader v ': e) a -> m e a 55 | runReader = raiseHandler . go 56 | where go :: PureEffects e => v -> Eff (Reader v ': e) a -> Eff e a 57 | go _ (Return a) = pure a 58 | go e (Effect Reader k) = go e (k e) 59 | go e (Effect (Local f m) k) = go (f e) m >>= go e . k 60 | go e (Other u k) = liftHandler (go e) u k 61 | 62 | -- | 63 | -- Locally rebind the value in the dynamic environment 64 | -- This function is like a relay; it is both an admin for Reader requests, 65 | -- and a requestor of them 66 | local :: forall v b m e. (Member (Reader v) e, Effectful m) => 67 | (v -> v) -> m e b -> m e b 68 | local f m = send (Local f (lowerEff m)) 69 | 70 | 71 | instance PureEffect (Reader r) 72 | instance Effect (Reader r) where 73 | handleState c dist (Request Reader k) = Request Reader (dist . (<$ c) . k) 74 | handleState c dist (Request (Local f a) k) = Request (Local f (dist (a <$ c))) (dist . fmap k) 75 | 76 | 77 | {- $simpleReaderExample 78 | 79 | In this example the @Reader@ monad provides access to variable bindings. 80 | Bindings are a @Map@ of integer variables. 81 | The variable @count@ contains number of variables in the bindings. 82 | You can see how to run a Reader effect and retrieve data from it 83 | with 'runReader', how to access the Reader data with 'ask' and 'asks'. 84 | 85 | >import Control.Monad.Effect 86 | >import Control.Monad.Effect.Reader 87 | >import Data.Map as Map 88 | >import Data.Maybe 89 | > 90 | >type Bindings = Map String Int 91 | > 92 | >-- Returns True if the "count" variable contains correct bindings size. 93 | >isCountCorrect :: Bindings -> Bool 94 | >isCountCorrect bindings = run $ runReader bindings calc_isCountCorrect 95 | > 96 | >-- The Reader effect, which implements this complicated check. 97 | >calc_isCountCorrect :: Eff '[Reader Bindings] Bool 98 | >calc_isCountCorrect = do 99 | > count <- asks (lookupVar "count") 100 | > bindings <- (ask :: Eff '[Reader Bindings] Bindings) 101 | > return (count == (Map.size bindings)) 102 | > 103 | >-- The selector function to use with 'asks'. 104 | >-- Returns value of the variable with specified name. 105 | >lookupVar :: String -> Bindings -> Int 106 | >lookupVar name bindings = fromJust (Map.lookup name bindings) 107 | > 108 | >sampleBindings :: Map.Map String Int 109 | >sampleBindings = Map.fromList [("count",3), ("1",1), ("b",2)] 110 | > 111 | >main = do 112 | > putStr $ "Count is correct for bindings " ++ (show sampleBindings) ++ ": " 113 | > putStrLn $ show (isCountCorrect sampleBindings) 114 | -} 115 | 116 | {- $localExample 117 | 118 | Shows how to modify Reader content with 'local'. 119 | 120 | > import Control.Monad.Effect 121 | > import Control.Monad.Effect.Reader 122 | > 123 | > import Data.Map as Map 124 | > import Data.Maybe 125 | > 126 | > type Bindings = Map String Int 127 | > 128 | > calculateContentLen :: Eff '[Reader String] Int 129 | > calculateContentLen = do 130 | > content <- (ask :: Eff '[Reader String] String) 131 | > return (length content) 132 | > 133 | > -- Calls calculateContentLen after adding a prefix to the Reader content. 134 | > calculateModifiedContentLen :: Eff '[Reader String] Int 135 | > calculateModifiedContentLen = local ("Prefix " ++) calculateContentLen 136 | > 137 | > main :: IO () 138 | > main = do 139 | > let s = "12345"; 140 | > let modifiedLen = run $ runReader s calculateModifiedContentLen; 141 | > let len = run $ runReader s calculateContentLen ; 142 | > putStrLn $ "Modified 's' length: " ++ (show modifiedLen) 143 | > putStrLn $ "Original 's' length: " ++ (show len) 144 | -} 145 | -------------------------------------------------------------------------------- /src/Control/Monad/Effect/Resource.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE DataKinds, FlexibleContexts, GADTs, RankNTypes, TypeOperators #-} 2 | 3 | {-| 4 | Cleanup handlers for precise resource management. 5 | -} 6 | 7 | module Control.Monad.Effect.Resource 8 | ( Resource (..) 9 | , bracket 10 | , runResource 11 | ) where 12 | 13 | import Control.Monad.Effect 14 | import Control.Monad.IO.Class 15 | import qualified Control.Exception as Exc 16 | 17 | data Resource m output where 18 | Resource :: m res -> (res -> m any) -> (res -> m output) -> Resource m output 19 | 20 | instance PureEffect Resource 21 | instance Effect Resource where 22 | handleState c dist (Request (Resource fore aft go) k) 23 | = Request (Resource (dist (fore <$ c)) (dist . fmap aft) (dist . fmap go)) (dist . fmap k) 24 | 25 | bracket :: (Member Resource effs, Effectful m) 26 | => m effs res 27 | -> (res -> m effs any) 28 | -> (res -> m effs b) 29 | -> m effs b 30 | bracket fore aft go = send (Resource (lowerEff fore) (lowerEff . aft) (lowerEff . go)) 31 | 32 | runResource :: (Member (Lift IO) effects, PureEffects effects) 33 | => (forall x . Eff effects x -> IO x) 34 | -> Eff (Resource ': effects) a 35 | -> Eff effects a 36 | runResource handler = interpret (\(Resource fore aft go) 37 | -> liftIO (Exc.bracket 38 | (handler (runResource handler fore)) 39 | (handler . runResource handler . aft) 40 | (handler . runResource handler . go))) 41 | -------------------------------------------------------------------------------- /src/Control/Monad/Effect/Resumable.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE DataKinds, FlexibleContexts, GADTs, LambdaCase, KindSignatures, Rank2Types, TypeOperators #-} 2 | module Control.Monad.Effect.Resumable 3 | ( Resumable(..) 4 | , SomeExc(..) 5 | , throwResumable 6 | , runResumable 7 | , runResumableWith 8 | ) where 9 | 10 | import Control.DeepSeq 11 | import Control.Monad.Effect.Internal 12 | import Data.Functor.Classes 13 | 14 | newtype Resumable exc (m :: * -> *) a = Resumable (exc a) 15 | 16 | throwResumable :: (Member (Resumable exc) e, Effectful m) => exc v -> m e v 17 | throwResumable = send . Resumable 18 | 19 | runResumable :: (Effectful m, Effects e) => m (Resumable exc ': e) a -> m e (Either (SomeExc exc) a) 20 | runResumable = raiseHandler go 21 | where go (Return a) = pure (Right a) 22 | go (Effect (Resumable e) _) = pure (Left (SomeExc e)) 23 | go (Other u k) = liftStatefulHandler (Right ()) (either (pure . Left) runResumable) u k 24 | 25 | -- | Run a 'Resumable' effect in an 'Effectful' context, using a handler to resume computation. 26 | runResumableWith :: (Effectful m, PureEffects effects) => (forall resume . exc resume -> m effects resume) -> m (Resumable exc ': effects) a -> m effects a 27 | runResumableWith handler = interpret (\ (Resumable e) -> handler e) 28 | 29 | 30 | data SomeExc exc where 31 | SomeExc :: exc v -> SomeExc exc 32 | 33 | instance Eq1 exc => Eq (SomeExc exc) where 34 | SomeExc exc1 == SomeExc exc2 = liftEq (const (const True)) exc1 exc2 35 | 36 | instance (Show1 exc) => Show (SomeExc exc) where 37 | showsPrec num (SomeExc exc) = liftShowsPrec (const (const id)) (const id) num exc 38 | 39 | instance NFData1 exc => NFData (SomeExc exc) where 40 | rnf (SomeExc exc) = liftRnf (\a -> seq a ()) exc 41 | 42 | instance PureEffect (Resumable exc) 43 | instance Effect (Resumable exc) where 44 | handleState c dist (Request (Resumable exc) k) = Request (Resumable exc) (dist . (<$ c) . k) 45 | -------------------------------------------------------------------------------- /src/Control/Monad/Effect/State.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE DataKinds, KindSignatures #-} 2 | {-# LANGUAGE TypeOperators #-} 3 | {-# LANGUAGE ScopedTypeVariables #-} 4 | {-# LANGUAGE GADTs #-} 5 | {-# LANGUAGE FlexibleContexts #-} 6 | 7 | {-| 8 | Module : Control.Monad.Effect.State 9 | Description : State effects for computations that carry state 10 | Copyright : Allele Dev 2015 11 | License : BSD-3 12 | Maintainer : allele.dev@gmail.com 13 | Stability : experimental 14 | Portability : POSIX 15 | 16 | Composable handler for State effects. 17 | 18 | Using as a 19 | starting point. 20 | 21 | -} 22 | module Control.Monad.Effect.State ( 23 | State(..), 24 | get, 25 | gets, 26 | put, 27 | modify, 28 | modify', 29 | runState, 30 | localState, 31 | transactionState 32 | ) where 33 | 34 | import Control.Monad.Effect.Internal 35 | import Data.Proxy 36 | 37 | -------------------------------------------------------------------------------- 38 | -- State, strict -- 39 | -------------------------------------------------------------------------------- 40 | 41 | -- | Run a 'State s' effect given an effect and an initial state. 42 | runState :: (Effectful m, Effects e) => s -> m (State s ': e) b -> m e (s, b) 43 | runState = raiseHandler . go 44 | where go s (Return a) = pure (s, a) 45 | go s (Effect Get k) = runState s (k s) 46 | go _ (Effect (Put s) k) = runState s (k ()) 47 | go s (Other u k) = liftStatefulHandler (s, ()) (uncurry runState) u k 48 | 49 | 50 | -- | Strict State effects: one can either Get values or Put them 51 | data State s (m :: * -> *) v where 52 | Get :: State s m s 53 | Put :: !s -> State s m () 54 | 55 | -- | Retrieve state 56 | get :: (Member (State s) e, Effectful m) => m e s 57 | get = send Get 58 | 59 | -- | Retrieve state, modulo a projection. 60 | gets :: (Member (State s) e, Effectful m) => (s -> a) -> m e a 61 | gets f = raiseEff (f <$> get) 62 | 63 | -- | Store state 64 | put :: (Member (State s) e, Effectful m) => s -> m e () 65 | put s = send (Put s) 66 | 67 | -- | Modify state 68 | modify :: (Member (State s) e, Effectful m) => (s -> s) -> m e () 69 | modify f = raiseEff (fmap f get >>= put) 70 | 71 | -- | Modify state strictly 72 | modify' :: (Member (State s) e, Effectful m) => (s -> s) -> m e () 73 | modify' f = raiseEff $ do 74 | v <- get 75 | put $! f v 76 | 77 | -- | 78 | -- An encapsulated State handler, for transactional semantics 79 | -- The global state is updated only if the transactionState finished 80 | -- successfully 81 | transactionState :: forall s e a m. (Member (State s) e, Effectful m) 82 | => Proxy s 83 | -> m e a 84 | -> m e a 85 | transactionState _ m = raiseEff $ do s <- get; loop s (lowerEff m) 86 | where 87 | loop :: s -> Eff e a -> Eff e a 88 | loop s (Return x) = put s >> pure x 89 | loop s (E (u :: Union e (Eff e) b) q) = case prj u :: Maybe (State s (Eff e) b) of 90 | Just Get -> loop s (apply q s) 91 | Just (Put s') -> loop s'(apply q ()) 92 | _ -> E u (tsingleton (Arrow k)) 93 | where k = q >>> (loop s) 94 | 95 | localState :: (Member (State s) effects, Effectful m) => (s -> s) -> m effects a -> m effects a 96 | localState f action = raiseEff $ do 97 | original <- get 98 | put (f original) 99 | v <- lowerEff action 100 | put original 101 | pure v 102 | 103 | 104 | instance PureEffect (State s) 105 | instance Effect (State s) where 106 | handleState c dist (Request Get k) = Request Get (dist . (<$ c) . k) 107 | handleState c dist (Request (Put s) k) = Request (Put s) (dist . (<$ c) . k) 108 | -------------------------------------------------------------------------------- /src/Control/Monad/Effect/StateRW.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE TypeOperators #-} 2 | {-# LANGUAGE DataKinds #-} 3 | {-# LANGUAGE FlexibleContexts #-} 4 | {-# LANGUAGE GADTs #-} 5 | 6 | {-| 7 | Module : Control.Monad.Effect.StateRW 8 | Description : State effects in terms of Reader/Writer 9 | Copyright : Allele Dev 2015 10 | License : BSD-3 11 | Maintainer : allele.dev@gmail.com 12 | Stability : experimental 13 | Portability : POSIX 14 | 15 | Composable handler for State effects in terms of Reader/Writer 16 | effects. This module is more a tutorial on how to compose handlers. It 17 | is slightly slower than a dedicated State handler. 18 | 19 | Using as a 20 | starting point. 21 | 22 | -} 23 | module Control.Monad.Effect.StateRW ( 24 | runStateR, 25 | Reader(..), 26 | Writer(..), 27 | tell, 28 | ask 29 | ) where 30 | 31 | import Control.Monad.Effect.Reader 32 | import Control.Monad.Effect.Writer 33 | import Control.Monad.Effect.Internal 34 | 35 | -- | State handler, using Reader/Writer effects 36 | runStateR :: (Effectful m, Effects e) => s -> m (Writer s ': Reader s ': e) a -> m e (s, a) 37 | runStateR = raiseHandler . go 38 | where go :: Effects e => s -> Eff (Writer s ': Reader s ': e) a -> Eff e (s, a) 39 | go s (Return a) = pure (s, a) 40 | go _ (Effect2_1 (Writer s) k) = go s (k ()) 41 | go s (Effect2_2 Reader k) = go s (k s) 42 | go s (Effect2_2 (Local f m) k) = go (f s) (m >>= k) 43 | go s (Other2 u k) = liftStatefulHandler (s, ()) (uncurry runStateR) u k 44 | -------------------------------------------------------------------------------- /src/Control/Monad/Effect/Trace.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE TypeOperators #-} 2 | {-# LANGUAGE DataKinds, KindSignatures #-} 3 | {-# LANGUAGE FlexibleContexts #-} 4 | {-# LANGUAGE GADTs #-} 5 | 6 | {-| 7 | Module : Control.Monad.Effect.Trace 8 | Description : Composable Trace effects 9 | Copyright : Allele Dev 2015 10 | License : BSD-3 11 | Maintainer : allele.dev@gmail.com 12 | Stability : experimental 13 | Portability : POSIX 14 | 15 | Composable handler for Trace effects. Trace allows one to debug the 16 | operation of sequences of effects by outputing to the console. 17 | 18 | Using as a 19 | starting point. 20 | 21 | -} 22 | module Control.Monad.Effect.Trace 23 | ( Trace(..) 24 | , trace 25 | , runPrintingTrace 26 | , runIgnoringTrace 27 | , runReturningTrace 28 | ) where 29 | 30 | import Control.Monad.Effect.Internal 31 | import Control.Monad.Effect.State 32 | import Control.Monad.IO.Class 33 | import Data.Bifunctor (first) 34 | import System.IO 35 | 36 | -- | A Trace effect; takes a String and performs output 37 | data Trace (m :: * -> *) v where 38 | Trace :: String -> Trace m () 39 | 40 | -- | Printing a string in a trace 41 | trace :: (Member Trace e, Effectful m) => String -> m e () 42 | trace = send . Trace 43 | 44 | -- | An IO handler for Trace effects. Prints output to stderr. 45 | runPrintingTrace :: (Member (Lift IO) effects, Effectful m, PureEffects effects) => m (Trace ': effects) a -> m effects a 46 | runPrintingTrace = raiseHandler (interpret (\ (Trace s) -> liftIO (hPutStrLn stderr s))) 47 | 48 | -- | Run a 'Trace' effect, discarding the traced values. 49 | runIgnoringTrace :: (Effectful m, PureEffects effects) => m (Trace ': effects) a -> m effects a 50 | runIgnoringTrace = raiseHandler (interpret (\ (Trace _) -> pure ())) 51 | 52 | -- | Run a 'Trace' effect, accumulating the traced values into a list like a 'Writer'. 53 | runReturningTrace :: (Effectful m, Effects effects) => m (Trace ': effects) a -> m effects ([String], a) 54 | runReturningTrace = raiseHandler (fmap (first reverse) . runState [] . reinterpret (\ (Trace s) -> modify' (s:))) 55 | 56 | 57 | instance PureEffect Trace 58 | instance Effect Trace where 59 | handleState c dist (Request (Trace s) k) = Request (Trace s) (dist . (<$ c) . k) 60 | -------------------------------------------------------------------------------- /src/Control/Monad/Effect/Writer.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE GADTs #-} 2 | {-# LANGUAGE TypeOperators #-} 3 | {-# LANGUAGE FlexibleContexts #-} 4 | {-# LANGUAGE DataKinds, KindSignatures #-} 5 | 6 | {-| 7 | Module : Control.Monad.Effect.Writer 8 | Description : Composable Writer effects 9 | Copyright : Allele Dev 2015 10 | License : BSD-3 11 | Maintainer : allele.dev@gmail.com 12 | Stability : experimental 13 | Portability : POSIX 14 | 15 | Writer effects, for writing changes to an attached environment. 16 | 17 | Using as a 18 | starting point. 19 | 20 | -} 21 | module Control.Monad.Effect.Writer ( 22 | Writer(..), 23 | tell, 24 | runWriter 25 | ) where 26 | 27 | import Control.Monad.Effect.Internal 28 | 29 | -- | Writer effects - send outputs to an effect environment 30 | data Writer o (m :: * -> *) x where 31 | Writer :: o -> Writer o m () 32 | 33 | -- | Send a change to the attached environment 34 | tell :: (Member (Writer o) e, Effectful m) => o -> m e () 35 | tell = send . Writer 36 | 37 | -- | Simple handler for Writer effects 38 | runWriter :: (Monoid o, Effectful m, Effects e) => m (Writer o ': e) a -> m e (o, a) 39 | runWriter = raiseHandler (go mempty) 40 | where go :: (Monoid o, Effects e) => o -> Eff (Writer o ': e) a -> Eff e (o, a) 41 | go w (Return a) = pure (w, a) 42 | go w (Effect (Writer o) k) = go (w `mappend` o) (k ()) 43 | go w (Other u k) = liftStatefulHandler (w, ()) (uncurry go) u k 44 | 45 | 46 | instance PureEffect (Writer o) 47 | instance Effect (Writer o) where 48 | handleState c dist (Request (Writer o) k) = Request (Writer o) (dist . (<$ c) . k) 49 | -------------------------------------------------------------------------------- /src/Data/Union.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE AllowAmbiguousTypes, ConstraintKinds, DataKinds, FlexibleInstances, GADTs, KindSignatures, MultiParamTypeClasses, RankNTypes, RoleAnnotations, ScopedTypeVariables, TypeApplications, TypeOperators #-} 2 | 3 | {-| 4 | Module : Data.Union 5 | Description : Open unions (type-indexed co-products) for extensible effects. 6 | Copyright : Allele Dev 2015 7 | License : BSD-3 8 | Maintainer : allele.dev@gmail.com 9 | Stability : experimental 10 | Portability : POSIX 11 | 12 | All operations are constant-time, and there is no Typeable constraint 13 | 14 | This is a variation of OpenUnion5.hs, which relies on overlapping 15 | instances instead of closed type families. Closed type families 16 | have their problems: overlapping instances can resolve even 17 | for unground types, but closed type families are subject to a 18 | strict apartness condition. 19 | 20 | This implementation is very similar to OpenUnion1.hs, but without 21 | the annoying Typeable constraint. We sort of emulate it: 22 | 23 | Our list r of open union components is a small Universe. 24 | Therefore, we can use the Typeable-like evidence in that 25 | universe. 26 | 27 | The data constructors of Union are not exported. 28 | -} 29 | 30 | module Data.Union 31 | ( Union 32 | , decompose 33 | , weaken 34 | , strengthen 35 | , inj 36 | , prj 37 | , Member 38 | , ForAll 39 | , forAll 40 | ) where 41 | 42 | import Unsafe.Coerce (unsafeCoerce) 43 | 44 | type role Union nominal nominal nominal 45 | 46 | -- Strong Sum (Existential with the evidence) is an open union 47 | -- t is can be a GADT and hence not necessarily a Functor. 48 | -- Int is the index of t in the list r; that is, the index of t in the 49 | -- universe r. 50 | data Union (r :: [ (* -> *) -> (* -> *) ]) (f :: * -> *) (v :: *) where 51 | Union :: {-# UNPACK #-} !Int -> t f v -> Union r f v 52 | 53 | -- | Inject a functor into a type-aligned union. 54 | inj :: forall e r f v. Member e r => e f v -> Union r f v 55 | inj = inj' (getOffset (offset :: Offset e r)) 56 | {-# INLINE inj #-} 57 | 58 | -- | Maybe project a functor out of a type-aligned union. 59 | prj :: forall e r f v. Member e r => Union r f v -> Maybe (e f v) 60 | prj = prj' (getOffset (offset :: Offset e r)) 61 | {-# INLINE prj #-} 62 | 63 | 64 | decompose :: Union (t ': r) f v -> Either (Union r f v) (t f v) 65 | decompose (Union 0 v) = Right $ unsafeCoerce v 66 | decompose (Union n v) = Left $ Union (n-1) v 67 | {-# INLINE [2] decompose #-} 68 | 69 | 70 | weaken :: Union r f v -> Union (any ': r) f v 71 | weaken (Union n v) = Union (n+1) v 72 | 73 | strengthen :: Union '[last] f v -> last f v 74 | strengthen (Union _ t) = unsafeCoerce t 75 | 76 | 77 | -- Find an index of an element in an `r'. 78 | -- The element must exist, so this is essentially a compile-time computation. 79 | class Member t r where 80 | offset :: Offset t r 81 | 82 | instance Member t (t ': r) where 83 | offset = Offset 0 84 | 85 | instance {-# OVERLAPPABLE #-} Member t r => Member t (t' ': r) where 86 | offset = Offset $ 1 + getOffset (offset :: Offset t r) 87 | 88 | 89 | -- Implementation details 90 | 91 | inj' :: Int -> t f v -> Union r f v 92 | inj' = Union 93 | {-# INLINE inj' #-} 94 | 95 | prj' :: Int -> Union r f v -> Maybe (t f v) 96 | prj' n (Union n' x) | n == n' = Just (unsafeCoerce x) 97 | | otherwise = Nothing 98 | {-# INLINE prj' #-} 99 | 100 | newtype Offset (t :: (* -> *) -> (* -> *)) (r :: [(* -> *) -> (* -> *)]) = Offset { getOffset :: Int } 101 | 102 | 103 | -- | Specialized version of 'decompose'. 104 | decompose0 :: Union '[t] f v -> Either (Union '[] f v) (t f v) 105 | decompose0 (Union _ v) = Right $ unsafeCoerce v 106 | -- No other case is possible 107 | {-# RULES "decompose/singleton" decompose = decompose0 #-} 108 | {-# INLINE decompose0 #-} 109 | 110 | 111 | -- | A constraint synonym stating that all members of a 'Union' satisfy some constraint. 112 | -- 113 | -- This is used to lift operations on members (made available by some typeclass) into operations on 'Union's. 114 | type ForAll typeclass members = ForAll' typeclass members 115 | 116 | -- | Lift an operation generalized over any possible member of a 'Union' into the 'Union'. 117 | forAll :: forall typeclass members m a c 118 | . ForAll typeclass members 119 | => (forall member . typeclass member => (forall n b . member n b -> Union members n b) -> member m a -> c) 120 | -> Union members m a 121 | -> c 122 | forAll f = forAll' @typeclass @members @members f 0 123 | {-# INLINE forAll #-} 124 | 125 | 126 | class ForAll' typeclass (members :: [(* -> *) -> (* -> *)]) where 127 | forAll' :: (forall member . typeclass member => (forall n b . member n b -> Union original n b) -> member m a -> c) -> Int -> Union original m a -> c 128 | 129 | instance ForAll' typeclass '[] where 130 | forAll' _ _ _ = error "impossible: forAll' on empty Union" 131 | {-# INLINE forAll' #-} 132 | 133 | instance (typeclass member, ForAll' typeclass members) => ForAll' typeclass (member ': members) where 134 | forAll' f n u@(Union n' t) 135 | | n == n' = f @member (Union n') (unsafeCoerce t) 136 | | otherwise = forAll' @typeclass @members f (n + 1) u 137 | {-# INLINE forAll' #-} 138 | -------------------------------------------------------------------------------- /stack.yaml: -------------------------------------------------------------------------------- 1 | flags: {} 2 | extra-package-dbs: [] 3 | packages: 4 | - '.' 5 | extra-deps: [] 6 | resolver: lts-10.3 7 | -------------------------------------------------------------------------------- /tests/Tests.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE TypeApplications #-} 2 | module Main where 3 | 4 | import Control.Monad.Effect 5 | 6 | import Test.Tasty 7 | import Test.Tasty.HUnit 8 | import Test.Tasty.QuickCheck 9 | 10 | import Tests.Coroutine 11 | import Tests.Exception 12 | import Tests.Fresh 13 | import Tests.NonDet 14 | import Tests.Reader 15 | import Tests.State 16 | import Tests.StateRW 17 | 18 | import qualified Data.List 19 | 20 | -------------------------------------------------------------------------------- 21 | -- Pure Tests -- 22 | -------------------------------------------------------------------------------- 23 | addInEff :: Int -> Int -> Int 24 | addInEff x y = run @Eff ((+) <$> pure x <*> pure y) 25 | 26 | pureTests :: TestTree 27 | pureTests = testGroup "Pure Eff tests" 28 | [ testProperty "Pure run just works: (+)" 29 | (\x y -> addInEff x y == x + y) 30 | ] 31 | 32 | -------------------------------------------------------------------------------- 33 | -- Coroutine Tests -- 34 | -------------------------------------------------------------------------------- 35 | 36 | -- | Counts number of consecutive pairs of odd elements at beginning of a list. 37 | countOddDuoPrefix :: [Int] -> Int 38 | countOddDuoPrefix list = count list 0 39 | where 40 | count (i1:i2:is) n = if even i1 && even i2 then n else count is (n+1) 41 | count _ n = n 42 | 43 | coroutineTests :: TestTree 44 | coroutineTests = testGroup "Coroutine Eff tests" 45 | [ testProperty "Counting consecutive pairs of odds" 46 | (\list -> runTestCoroutine list == countOddDuoPrefix list) 47 | ] 48 | 49 | -------------------------------------------------------------------------------- 50 | -- Exception Tests -- 51 | -------------------------------------------------------------------------------- 52 | exceptionTests :: TestTree 53 | exceptionTests = testGroup "Exception Eff tests" 54 | [ testProperty "Exc takes precedence" (\x y -> testExceptionTakesPriority x y == Left y) 55 | , testCase "uncaught: runState (runError t)" $ 56 | ter1 @?= (2, Left "exc") 57 | , testCase "uncaught: runError (runState t)" $ 58 | ter2 @?= Left "exc" 59 | , testCase "caught: runState (runError t)" $ 60 | ter3 @?= (2, Right "exc") 61 | , testCase "caught: runError (runState t)" $ 62 | ter4 @?= Right (1, "exc") 63 | , testCase "success: runReader (runErrBig t)" (ex2rr @?= Right 5) 64 | , testCase "uncaught: runReader (runErrBig t)" $ 65 | ex2rr1 @?= Left (TooBig 7) 66 | , testCase "uncaught: runErrBig (runReader t)" $ 67 | ex2rr2 @?= Left (TooBig 7) 68 | ] 69 | 70 | -------------------------------------------------------------------------------- 71 | -- Fresh Effect Tests -- 72 | -------------------------------------------------------------------------------- 73 | freshTests :: TestTree 74 | freshTests = testGroup "Fresh tests" 75 | [ testCase "Start at 0, refresh twice, yields 1" (testFresh 10 @?= 9) 76 | , testProperty "Freshening n times yields (n-1)" (\n -> n > 0 ==> testFresh n == (n-1)) 77 | ] 78 | 79 | -------------------------------------------------------------------------------- 80 | -- Nondeterministic Effect Tests -- 81 | -------------------------------------------------------------------------------- 82 | -- https://wiki.haskell.org/Prime_numbers 83 | primesTo :: Int -> [Int] 84 | primesTo m = sieve [2..m] {- (\\) is set-difference for unordered lists -} 85 | where 86 | sieve (x:xs) = x : sieve (xs Data.List.\\ [x,x+x..m]) 87 | sieve [] = [] 88 | 89 | nonDetTests :: TestTree 90 | nonDetTests = testGroup "NonDet tests" 91 | [ testProperty "Primes in 2..n generated by ifte" 92 | (\n' -> let n = abs n' in testIfte [2..n] == primesTo n) 93 | ] 94 | 95 | -------------------------------------------------------------------------------- 96 | -- Reader Effect Tests -- 97 | -------------------------------------------------------------------------------- 98 | readerTests :: TestTree 99 | readerTests = testGroup "Reader tests" 100 | [ testProperty "Reader passes along environment: n + x" 101 | (\n x -> testReader n x == n + x) 102 | , testProperty "Multiple readers work" 103 | (\f n -> testMultiReader f n == ((f + 2.0) + fromIntegral (n + 1))) 104 | , testProperty "Local injects into env" 105 | (\env inc -> testLocal env inc == 2*(env+1) + inc) 106 | ] 107 | 108 | -------------------------------------------------------------------------------- 109 | -- State[RW] Effect Tests -- 110 | -------------------------------------------------------------------------------- 111 | stateTests :: TestTree 112 | stateTests = testGroup "State tests" 113 | [ testProperty "get after put n yields (n,n)" (\n -> testPutGet n 0 == (n,n)) 114 | , testProperty "Final put determines stored state" $ 115 | \p1 p2 start -> testPutGetPutGetPlus p1 p2 start == (p2, p1+p2) 116 | , testProperty "If only getting, start state determines outcome" $ 117 | \start -> testGetStart start == (start,start) 118 | , testProperty "testPutGet: State == StateRW" $ 119 | \n -> testPutGet n 0 == testPutGetRW n 0 120 | , testProperty "testPutGetPutGetPlus: State == StateRW" $ 121 | \p1 p2 start -> testPutGetPutGetPlus p1 p2 start == testPutGetPutGetPlusRW p1 p2 start 122 | , testProperty "testGetStart: State == StateRW" $ 123 | \n -> testGetStart n == testGetStartRW n 124 | ] 125 | 126 | -------------------------------------------------------------------------------- 127 | -- Runner -- 128 | -------------------------------------------------------------------------------- 129 | main :: IO () 130 | main = defaultMain $ testGroup "Tests" 131 | [ pureTests 132 | , coroutineTests 133 | , exceptionTests 134 | , freshTests 135 | , nonDetTests 136 | , readerTests 137 | , stateTests 138 | ] 139 | -------------------------------------------------------------------------------- /tests/Tests/Common.hs: -------------------------------------------------------------------------------- 1 | module Tests.Common where 2 | 3 | import Control.Applicative 4 | 5 | add :: Applicative f => f Int -> f Int -> f Int 6 | add = liftA2 (+) 7 | -------------------------------------------------------------------------------- /tests/Tests/Coroutine.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE FlexibleContexts #-} 2 | {-# LANGUAGE TypeOperators #-} 3 | {-# LANGUAGE DataKinds #-} 4 | 5 | module Tests.Coroutine ( 6 | runTestCoroutine 7 | ) where 8 | 9 | import Control.Monad 10 | import Control.Monad.Effect 11 | import Control.Monad.Effect.Coroutine 12 | import Control.Monad.Effect.State 13 | 14 | runTestCoroutine :: [Int] -> Int 15 | runTestCoroutine list = fst . run $ runState 0 effTestCoroutine 16 | where 17 | testCoroutine :: (Member (Yield () Int) e, Member (State Int) e) => Eff e () 18 | testCoroutine = do 19 | -- yield for two elements and hope they're both odd 20 | b <- (&&) 21 | <$> yield () (even :: Int -> Bool) 22 | <*> yield () (even :: Int -> Bool) 23 | unless b (modify ((+1) :: Int -> Int) >> testCoroutine) 24 | 25 | effTestCoroutine = do 26 | status <- runC testCoroutine 27 | handleStatus list status 28 | where 29 | handleStatus (i:is) (Continue () k) = k i >>= handleStatus is 30 | handleStatus _ _ = pure () 31 | -------------------------------------------------------------------------------- /tests/Tests/Exception.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE TypeApplications #-} 2 | {-# LANGUAGE TypeOperators #-} 3 | {-# LANGUAGE DataKinds #-} 4 | {-# LANGUAGE FlexibleContexts #-} 5 | module Tests.Exception ( 6 | TooBig(..), 7 | 8 | testExceptionTakesPriority, 9 | 10 | ter1, 11 | ter2, 12 | ter3, 13 | ter4, 14 | 15 | ex2rr, 16 | ex2rr1, 17 | ex2rr2, 18 | ) where 19 | 20 | import Control.Monad.Effect 21 | import Control.Monad.Effect.Exception 22 | import Control.Monad.Effect.Reader 23 | import Control.Monad.Effect.State 24 | 25 | import Tests.Common 26 | 27 | testExceptionTakesPriority :: Int -> Int -> Either Int Int 28 | testExceptionTakesPriority x y = run @Eff $ runError (go x y) 29 | where go a b = pure a `add` throwError b 30 | 31 | -- The following won't type: unhandled exception! 32 | -- ex2rw = run et2 33 | {- 34 | No instance for (Member (Exc Int) Void) 35 | arising from a use of `et2' 36 | -} 37 | 38 | -- exceptions and state 39 | incr :: Member (State Int) r => Eff r () 40 | incr = get >>= put . (+ (1::Int)) 41 | 42 | tes1 :: (Member (State Int) r, Member (Exc String) r) => Eff r b 43 | tes1 = do 44 | incr 45 | throwError "exc" 46 | 47 | ter1 :: (Int, Either String Int) 48 | ter1 = run $ runState (1::Int) (runError tes1) 49 | 50 | ter2 :: Either String (Int, String) 51 | ter2 = run $ runError (runState (1::Int) tes1) 52 | 53 | teCatch :: Member (Exc String) r => Eff r a -> Eff r String 54 | teCatch m = catchError (m >> pure "done") (\e -> pure (e::String)) 55 | 56 | ter3 :: (Int, Either String String) 57 | ter3 = run $ runState (1::Int) (runError (teCatch tes1)) 58 | 59 | ter4 :: Either String (Int, String) 60 | ter4 = run $ runError (runState (1::Int) (teCatch tes1)) 61 | 62 | -- The example from the paper 63 | newtype TooBig = TooBig Int deriving (Eq, Show) 64 | 65 | ex2 :: Member (Exc TooBig) r => Eff r Int -> Eff r Int 66 | ex2 m = do 67 | v <- m 68 | if v > 5 then throwError (TooBig v) 69 | else pure v 70 | 71 | -- specialization to tell the type of the exception 72 | runErrBig :: Effects r => Eff (Exc TooBig ': r) a -> Eff r (Either TooBig a) 73 | runErrBig = runError 74 | 75 | ex2rr :: Either TooBig Int 76 | ex2rr = run go 77 | where go = runReader (5::Int) (runErrBig (ex2 ask)) 78 | 79 | ex2rr1 :: Either TooBig Int 80 | ex2rr1 = run $ runReader (7::Int) (runErrBig (ex2 ask)) 81 | 82 | -- Different order of handlers (layers) 83 | ex2rr2 :: Either TooBig Int 84 | ex2rr2 = run $ runErrBig (runReader (7::Int) (ex2 ask)) 85 | -------------------------------------------------------------------------------- /tests/Tests/Fresh.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE FlexibleContexts #-} 2 | module Tests.Fresh where 3 | 4 | import Control.Monad 5 | import Control.Monad.Effect 6 | import Control.Monad.Effect.Fresh 7 | 8 | makeFresh :: Effects r => Int -> Eff r Int 9 | makeFresh n = runFresh 0 (liftM last (replicateM n fresh)) 10 | 11 | testFresh :: Int -> Int 12 | testFresh = run . makeFresh 13 | -------------------------------------------------------------------------------- /tests/Tests/NonDet.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE FlexibleContexts, TypeOperators #-} 2 | module Tests.NonDet where 3 | 4 | import Control.Applicative 5 | import Control.Monad 6 | import Control.Monad.Effect 7 | import Control.Monad.Effect.NonDet 8 | 9 | ifte :: Member NonDet e 10 | => Eff e a 11 | -> (a -> Eff e b) 12 | -> Eff e b 13 | -> Eff e b 14 | ifte t th el = msplit t >>= maybe el (\(a,m) -> th a <|> (m >>= th)) 15 | 16 | generatePrimes :: Member NonDet e => [Int] -> Eff e Int 17 | generatePrimes xs = do 18 | n <- gen 19 | ifte (do d <- gen 20 | guard $ d < n && n `mod` d == 0) 21 | (const mzero) 22 | (pure n) 23 | where gen = msum (fmap pure xs) 24 | 25 | testIfte :: [Int] -> [Int] 26 | testIfte = run . runNonDetA . generatePrimes 27 | -------------------------------------------------------------------------------- /tests/Tests/Reader.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE FlexibleContexts #-} 2 | {-# LANGUAGE TypeApplications #-} 3 | module Tests.Reader ( 4 | testReader, 5 | testMultiReader, 6 | testLocal 7 | ) where 8 | 9 | import Control.Monad.Effect 10 | import Control.Monad.Effect.Reader 11 | 12 | import Tests.Common 13 | 14 | -------------------------------------------------------------------------------- 15 | -- Examples -- 16 | -------------------------------------------------------------------------------- 17 | testReader :: Int -> Int -> Int 18 | testReader n x = run @Eff . runReader n $ ask `add` pure x 19 | 20 | {- 21 | t1rr' = run t1 22 | No instance for (Member (Reader Int) Void) 23 | arising from a use of `t1' 24 | -} 25 | 26 | testMultiReader :: Float -> Int -> Float 27 | testMultiReader f n = run @Eff . runReader f . runReader n $ t2 28 | where t2 = do 29 | v1 <- ask 30 | v2 <- ask 31 | return $ fromIntegral (v1 + (1::Int)) + (v2 + (2::Float)) 32 | 33 | -- The opposite order of layers 34 | {- If we mess up, we get an error 35 | t2rrr1' = run $ runReader (10::Float) (runReader (20::Float) t2) 36 | No instance for (Member (Reader Int) []) 37 | arising from a use of `t2' 38 | -} 39 | 40 | testLocal :: Int -> Int -> Int 41 | testLocal env inc = run @Eff $ runReader env t3 42 | where t3 = t1 `add` local (+ inc) t1 43 | t1 = ask `add` return (1 :: Int) 44 | -------------------------------------------------------------------------------- /tests/Tests/State.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE FlexibleContexts #-} 2 | {-# LANGUAGE TypeApplications #-} 3 | module Tests.State ( 4 | testPutGet, 5 | testPutGetPutGetPlus, 6 | testGetStart 7 | ) where 8 | 9 | import Control.Monad.Effect 10 | import Control.Monad.Effect.State 11 | 12 | testPutGet :: Int -> Int -> (Int,Int) 13 | testPutGet n start = run @Eff (runState start go) 14 | where go = put n >> get 15 | 16 | testPutGetPutGetPlus :: Int -> Int -> Int -> (Int,Int) 17 | testPutGetPutGetPlus p1 p2 start = run @Eff (runState start go) 18 | where go = do 19 | put p1 20 | x <- get 21 | put p2 22 | y <- get 23 | return (x+y) 24 | 25 | testGetStart :: Int -> (Int,Int) 26 | testGetStart start = run @Eff (runState start get) 27 | -------------------------------------------------------------------------------- /tests/Tests/StateRW.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE TypeApplications #-} 2 | {-# LANGUAGE FlexibleContexts #-} 3 | module Tests.StateRW ( 4 | testPutGetRW, 5 | testPutGetPutGetPlusRW, 6 | testGetStartRW 7 | ) where 8 | 9 | import Control.Monad.Effect 10 | import Control.Monad.Effect.StateRW 11 | 12 | testPutGetRW :: Int -> Int -> (Int,Int) 13 | testPutGetRW n start = run @Eff (runStateR start go) 14 | where go = tell n >> ask 15 | 16 | testPutGetPutGetPlusRW :: Int -> Int -> Int -> (Int,Int) 17 | testPutGetPutGetPlusRW p1 p2 start = run @Eff (runStateR start go) 18 | where go = do 19 | tell p1 20 | x <- ask 21 | tell p2 22 | y <- ask 23 | return (x+y) 24 | 25 | testGetStartRW :: Int -> (Int,Int) 26 | testGetStartRW start = run @Eff (runStateR start go) 27 | where go = ask 28 | -------------------------------------------------------------------------------- /tests/Tests/Union.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE DataKinds, KindSignatures #-} 2 | module Tests.Union where 3 | 4 | import Data.Functor.Identity 5 | import Data.Union 6 | 7 | newtype I (m :: * -> *) a = I { getI :: a } 8 | newtype K s (m :: * -> *) a = K { getK :: s } 9 | 10 | testUnaryUnion :: Int -> Union '[I] Identity Int 11 | testUnaryUnion n = inj (I n) 12 | 13 | testBinaryUnion0 :: Int -> Union '[I, K String] Identity Int 14 | testBinaryUnion0 n = inj (I n) 15 | 16 | testBinaryUnion1 :: String -> Union '[I, K String] Identity Int 17 | testBinaryUnion1 s = inj (K s) 18 | --------------------------------------------------------------------------------