├── .gitignore ├── LICENSE ├── README.md ├── Setup.hs ├── effin.cabal └── src ├── Control ├── Effect.hs ├── Effect │ ├── Bracket.hs │ ├── Coroutine.hs │ ├── Exception.hs │ ├── Lift.hs │ ├── List.hs │ ├── Reader.hs │ ├── State.hs │ ├── Thread.hs │ ├── Witness.hs │ └── Writer.hs └── Monad │ └── Effect.hs └── Data ├── Index.hs ├── Type ├── Nat.hs └── Row.hs └── Union.hs /.gitignore: -------------------------------------------------------------------------------- 1 | dist 2 | cabal-dev 3 | cabal.sandbox.config 4 | *.o 5 | *.hi 6 | *.chi 7 | *.chs.h 8 | *.sublime-project 9 | *.sublime-workspace 10 | .cabal-sandbox 11 | .virthualenv 12 | .hdevtools.sock 13 | -------------------------------------------------------------------------------- /LICENSE: -------------------------------------------------------------------------------- 1 | Copyright (c) 2014, Anthony Vandikas 2 | 3 | All rights reserved. 4 | 5 | Redistribution and use in source and binary forms, with or without 6 | modification, are permitted provided that the following conditions are met: 7 | 8 | * Redistributions of source code must retain the above copyright 9 | notice, this list of conditions and the following disclaimer. 10 | 11 | * Redistributions in binary form must reproduce the above 12 | copyright notice, this list of conditions and the following 13 | disclaimer in the documentation and/or other materials provided 14 | with the distribution. 15 | 16 | * Neither the name of Anthony Vandikas nor the names of other 17 | contributors may be used to endorse or promote products derived 18 | from this software without specific prior written permission. 19 | 20 | THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS 21 | "AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT 22 | LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR 23 | A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT 24 | OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, 25 | SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT 26 | LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, 27 | DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY 28 | THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT 29 | (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE 30 | OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. 31 | -------------------------------------------------------------------------------- /README.md: -------------------------------------------------------------------------------- 1 | effin: Extensible Effects 2 | ========================= 3 | 4 | This package implements extensible effects, an alternative to monad transformers. 5 | The original paper can be found at http://okmij.org/ftp/Haskell/extensible/exteff.pdf. 6 | The main differences between this library and the one described in the paper are 7 | that this library does not use the Typeable type class, does not require that 8 | effects implement the Functor type class, and has a simpler API for handling 9 | effects. 10 | 11 | For example, the following code implements a handler for exceptions: 12 | 13 | newtype Exception e = Throw e 14 | 15 | runException :: Effect (Exception e :+ es) a -> Effect es (Either e a) 16 | runException = eliminate 17 | (\x -> return (Right x)) 18 | (\(Throw e) k -> return (Left e)) 19 | 20 | Compare this to the corresponding code in extensible-effects 21 | (http://hackage.haskell.org/package/extensible-effects): 22 | 23 | runExc :: Typeable e => Eff (Exc e :> r) a -> Eff r (Either e a) 24 | runExc = loop . admin 25 | where 26 | loop (Val x) = return (Right x) 27 | loop (E u) = handleRelay u loop (\(Exc e) -> return (Left e)) 28 | 29 | In particular, effect implementors are not required to do any recursion, thereby 30 | making effect handlers more composeable. 31 | 32 | Future Work 33 | =========== 34 | 35 | * Support for GHC 7.6. This will require ~~very~~ extremely heavy abuse of `OverlappingInstances`, but it can be done. 36 | * ~~Encapsulation of effects.~~ Done. 37 | * Improved exceptions. Currently: 38 | * ~~The `finally` function only works with an exception of a single type.~~ Fixed. 39 | * IO/Async exceptions aren't yet supported. 40 | * Support for effects that require linearity. In particular, any `Region` effect would be 41 | unsafe because there's no way to ensure that effects like `Thread` aren't used simultaneously. 42 | Perhaps this can be achieved with something akin to how the IO monad ensures linearity. 43 | -------------------------------------------------------------------------------- /Setup.hs: -------------------------------------------------------------------------------- 1 | import Distribution.Simple 2 | main = defaultMain 3 | -------------------------------------------------------------------------------- /effin.cabal: -------------------------------------------------------------------------------- 1 | name: effin 2 | version: 0.3.0.3 3 | synopsis: A Typeable-free implementation of extensible effects 4 | homepage: https://github.com/YellPika/effin 5 | license: BSD3 6 | license-file: LICENSE 7 | author: Anthony Vandikas 8 | maintainer: yellpika@gmail.com 9 | copyright: (c) 2014 Anthony Vandikas 10 | category: Control, Effect 11 | build-type: Simple 12 | cabal-version: >=1.10 13 | description: 14 | This package implements extensible effects, an alternative to monad 15 | transformers. The original paper can be found at 16 | . The main differences 17 | between this library and the one described in the paper are that this library 18 | does not use the Typeable type class, does not require that effects implement 19 | the Functor type class, and has a simpler API for handling 20 | effects. 21 | . 22 | For example, the following code implements a handler for exceptions: 23 | . 24 | > newtype Exception e = Throw e 25 | > 26 | > runException :: Effect (Exception e :+ es) a -> Effect es (Either e a) 27 | > runException = eliminate 28 | > (\x -> return (Right x)) 29 | > (\(Throw e) k -> return (Left e)) 30 | . 31 | Compare this to the corresponding code in extensible-effects 32 | (): 33 | . 34 | > runExc :: Typeable e => Eff (Exc e :> r) a -> Eff r (Either e a) 35 | > runExc = loop . admin 36 | > where 37 | > loop (Val x) = return (Right x) 38 | > loop (E u) = handleRelay u loop (\(Exc e) -> return (Left e)) 39 | . 40 | In particular, effect implementors are not required to do any recursion, 41 | thereby making effect handlers more composeable. 42 | 43 | flag mtl 44 | description: Enable MTL support 45 | default: True 46 | manual: True 47 | 48 | library 49 | exposed-modules: 50 | Control.Effect, 51 | Control.Effect.Bracket, 52 | Control.Effect.Coroutine, 53 | Control.Effect.Exception, 54 | Control.Effect.Reader, 55 | Control.Effect.Lift, 56 | Control.Effect.List, 57 | Control.Effect.State, 58 | Control.Effect.Thread, 59 | Control.Effect.Witness, 60 | Control.Effect.Writer, 61 | Control.Monad.Effect 62 | 63 | other-modules: 64 | Data.Index, 65 | Data.Type.Row, 66 | Data.Type.Nat 67 | Data.Union 68 | 69 | build-depends: base >= 4.7 && < 4.11 70 | if flag(mtl) 71 | build-depends: mtl >= 2.1 && < 3 72 | 73 | hs-source-dirs: src 74 | default-language: Haskell2010 75 | ghc-options: -Wall 76 | 77 | if flag(mtl) 78 | cpp-options: -DMTL 79 | 80 | source-repository head 81 | type: git 82 | location: git://github.com/YellPika/effin.git 83 | -------------------------------------------------------------------------------- /src/Control/Effect.hs: -------------------------------------------------------------------------------- 1 | module Control.Effect ( 2 | module Control.Effect.Bracket, 3 | module Control.Effect.Coroutine, 4 | module Control.Effect.Exception, 5 | module Control.Effect.Lift, 6 | module Control.Effect.List, 7 | module Control.Effect.Reader, 8 | module Control.Effect.State, 9 | module Control.Effect.Thread, 10 | module Control.Effect.Witness, 11 | module Control.Effect.Writer, 12 | module Control.Monad.Effect 13 | ) where 14 | 15 | import Control.Effect.Bracket 16 | import Control.Effect.Coroutine 17 | import Control.Effect.Exception 18 | import Control.Effect.Lift 19 | import Control.Effect.List 20 | import Control.Effect.Reader 21 | import Control.Effect.State 22 | import Control.Effect.Thread 23 | import Control.Effect.Witness 24 | import Control.Effect.Writer 25 | import Control.Monad.Effect 26 | -------------------------------------------------------------------------------- /src/Control/Effect/Bracket.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE DataKinds #-} 2 | {-# LANGUAGE FlexibleInstances #-} 3 | {-# LANGUAGE FlexibleContexts #-} 4 | {-# LANGUAGE GADTs #-} 5 | {-# LANGUAGE MultiParamTypeClasses #-} 6 | {-# LANGUAGE RankNTypes #-} 7 | {-# LANGUAGE TypeFamilies #-} 8 | {-# LANGUAGE TypeOperators #-} 9 | {-# LANGUAGE UndecidableInstances #-} 10 | 11 | module Control.Effect.Bracket ( 12 | EffectBracket, Bracket, runBracket, 13 | Tag, newTag, raiseWith, exceptWith, 14 | Handler, exceptAny, bracket, finally 15 | ) where 16 | 17 | import Data.Maybe (fromMaybe, listToMaybe, mapMaybe) 18 | import Data.Type.Equality ((:~:) (..), TestEquality (..)) 19 | import Control.Effect.Witness 20 | import Control.Monad.Effect 21 | 22 | -- | Provides a base effect for exceptions. This effect allows the dynamic 23 | -- generation of exception classes at runtime. 24 | data Bracket s a where 25 | Raise :: Tag s b -> b -> Bracket s a 26 | BWitness :: Witness s a -> Bracket s a 27 | 28 | -- | The type of placeholder values indicating an exception class. 29 | data Tag s a = Tag (a -> String) (Token s a) 30 | 31 | instance TestEquality (Tag s) where 32 | testEquality (Tag _ i) (Tag _ j) = testEquality i j 33 | 34 | type instance Is Bracket f = IsBracket f 35 | 36 | type family IsBracket f where 37 | IsBracket (Bracket s) = 'True 38 | IsBracket f = 'False 39 | 40 | class MemberEffect Bracket (Bracket s) l => EffectBracket s l 41 | instance MemberEffect Bracket (Bracket s) l => EffectBracket s l 42 | 43 | -- | Creates a new tag. The function parameter describes the error message that 44 | -- is shown in the case of an uncaught exception. 45 | newTag :: EffectBracket s l => (a -> String) -> Effect l (Tag s a) 46 | newTag toString = conceal $ fmap (Tag toString) (rename BWitness newToken) 47 | 48 | -- | Raises an exception of the specified class and value. 49 | raiseWith :: EffectBracket s l => Tag s b -> b -> Effect l a 50 | raiseWith tag value = send $ Raise tag value 51 | 52 | -- | Specifies a handler for exceptions of a given class. 53 | exceptWith :: EffectBracket s l => Tag s b -> Effect l a -> (b -> Effect l a) -> Effect l a 54 | exceptWith tag effect handler = exceptAny effect [Handler tag handler] 55 | 56 | -- | A handler for an exception. Use with `exceptAny`. 57 | data Handler s l a where 58 | Handler :: Tag s b -> (b -> Effect l a) -> Handler s l a 59 | 60 | -- | Specifies a number of handlers for exceptions thrown by the given 61 | -- computation. This is prefered over chained calles to `exceptWith`, i.e. 62 | -- 63 | -- > exceptWith t2 (exceptWith t1 m h1) h2 64 | -- 65 | -- because @h2@ could catch exceptions thrown by @h1@. 66 | exceptAny :: EffectBracket s l => Effect l a -> [Handler s l a] -> Effect l a 67 | exceptAny effect handlers = effect `exceptAll` \i x -> 68 | let try (Handler j f) = fmap (\Refl -> f x) (testEquality i j) 69 | results = mapMaybe try handlers 70 | in fromMaybe (raiseWith i x) (listToMaybe results) 71 | 72 | -- | Intercepts all exceptions. Used to implement `exceptWith` and `bracket`. 73 | -- Not exported. Is it really a good thing to allow catching all exceptions? 74 | -- The most common use case for catching all exceptions is to do cleanup, which 75 | -- is what bracket is for. 76 | exceptAll :: EffectBracket s l => Effect l a -> (forall b. Tag s b -> b -> Effect l a) -> Effect l a 77 | exceptAll effect handler = intercept 78 | return 79 | (\b k -> 80 | case b of 81 | Raise t x -> handler t x 82 | _ -> send b >>= k) 83 | effect 84 | 85 | -- | Executes a computation with a resource, and ensures that the resource is 86 | -- cleaned up afterwards. 87 | bracket :: EffectBracket s l 88 | => Effect l a -- ^ The 'acquire' operation. 89 | -> (a -> Effect l ()) -- ^ The 'release' operation. 90 | -> (a -> Effect l b) -- ^ The computation to perform. 91 | -> Effect l b 92 | bracket acquire destroy run = do 93 | resource <- acquire 94 | result <- run resource `exceptAll` \e x -> do 95 | destroy resource 96 | raiseWith e x 97 | destroy resource 98 | return result 99 | 100 | -- | A specialized version of `bracket` which 101 | -- does not require an 'acquire' operation. 102 | finally :: EffectBracket s l => Effect l a -> Effect l () -> Effect l a 103 | finally effect finalizer = bracket 104 | (return ()) 105 | (const finalizer) 106 | (const effect) 107 | 108 | -- | Executes a `Bracket` effect. The Rank-2 type ensures that `Tag`s do not 109 | -- escape their scope. 110 | runBracket :: (forall s. Effect (Bracket s ':+ l) a) -> Effect l a 111 | runBracket effect = runWitness (convert effect) 112 | 113 | convert :: Effect (Bracket s ':+ l) a -> Effect (Witness s ':+ l) a 114 | convert = 115 | eliminate 116 | return 117 | (\t k -> 118 | case t of 119 | Raise (Tag f _) x -> error (f x) 120 | BWitness w -> send w >>= k) 121 | . swap 122 | . extend 123 | -------------------------------------------------------------------------------- /src/Control/Effect/Coroutine.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE DataKinds #-} 2 | {-# LANGUAGE FlexibleContexts #-} 3 | {-# LANGUAGE FlexibleInstances #-} 4 | {-# LANGUAGE MultiParamTypeClasses #-} 5 | {-# LANGUAGE TypeFamilies #-} 6 | {-# LANGUAGE TypeOperators #-} 7 | {-# LANGUAGE UndecidableInstances #-} 8 | 9 | module Control.Effect.Coroutine ( 10 | EffectCoroutine, Coroutine, runCoroutine, suspend, 11 | Iterator (..), evalIterator 12 | ) where 13 | 14 | import Control.Monad.Effect 15 | 16 | -- | An effect describing a suspendable computation. 17 | data Coroutine i o a = Coroutine (o -> a) i 18 | 19 | type instance Is Coroutine f = IsCoroutine f 20 | 21 | type family IsCoroutine f where 22 | IsCoroutine (Coroutine i o) = 'True 23 | IsCoroutine f = 'False 24 | 25 | class MemberEffect Coroutine (Coroutine i o) l => EffectCoroutine i o l 26 | instance MemberEffect Coroutine (Coroutine i o) l => EffectCoroutine i o l 27 | 28 | -- | Suspends the current computation by providing a value 29 | -- of type `i` and then waiting for a value of type `o`. 30 | suspend :: EffectCoroutine i o l => i -> Effect l o 31 | suspend = send . Coroutine id 32 | 33 | -- | Converts a `Coroutine` effect into an `Iterator`. 34 | runCoroutine :: Effect (Coroutine i o ':+ l) a -> Effect l (Iterator i o l a) 35 | runCoroutine = eliminate (return . Done) (\(Coroutine f x) k -> return (Next (k . f) x)) 36 | 37 | -- | A suspended computation. 38 | data Iterator i o l a 39 | = Done a -- ^ Describes a finished computation. 40 | | Next (o -> Effect l (Iterator i o l a)) i 41 | -- ^ Describes a computation that provided a value 42 | -- of type `i` and awaits a value of type `o`. 43 | 44 | -- | Evaluates an iterator by providing it with an input stream. 45 | evalIterator :: Iterator i o l a -> [o] -> Effect l (Iterator i o l a, [i]) 46 | evalIterator (Next f v) (x:xs) = do 47 | i <- f x 48 | (r, vs) <- evalIterator i xs 49 | return (r, v:vs) 50 | evalIterator i _ = return (i, []) 51 | -------------------------------------------------------------------------------- /src/Control/Effect/Exception.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE CPP #-} 2 | {-# LANGUAGE DataKinds #-} 3 | {-# LANGUAGE FlexibleContexts #-} 4 | {-# LANGUAGE FlexibleInstances #-} 5 | {-# LANGUAGE MultiParamTypeClasses #-} 6 | {-# LANGUAGE TypeFamilies #-} 7 | {-# LANGUAGE TypeOperators #-} 8 | {-# LANGUAGE UndecidableInstances #-} 9 | 10 | #if MTL 11 | {-# OPTIONS_GHC -fno-warn-orphans #-} 12 | #endif 13 | 14 | module Control.Effect.Exception ( 15 | EffectException, Exception, runException, 16 | raise, except 17 | ) where 18 | 19 | import Control.Effect.Bracket 20 | import Control.Monad.Effect 21 | 22 | #ifdef MTL 23 | import Data.Type.Row 24 | import qualified Control.Monad.Error.Class as E 25 | 26 | instance (EffectBracket s l, Member (Exception s e) l, Exception s e ~ InstanceOf Exception l) => E.MonadError e (Effect l) where 27 | throwError = raise 28 | catchError = except 29 | #endif 30 | 31 | -- | An effect that describes the possibility of failure. 32 | newtype Exception s e a = Exception (Tag s e -> a) 33 | 34 | type instance Is Exception f = IsException f 35 | 36 | type family IsException f where 37 | IsException (Exception s e) = 'True 38 | IsException f = 'False 39 | 40 | class (EffectBracket s l, MemberEffect Exception (Exception s e) l) => EffectException s e l 41 | instance (EffectBracket s l, MemberEffect Exception (Exception s e) l) => EffectException s e l 42 | 43 | -- | Raises an exception. 44 | raise :: EffectException s e l => e -> Effect l a 45 | raise e = sendEffect (Exception (\tag -> raiseWith tag e)) 46 | 47 | -- | Handles an exception. Intended to be used in infix form. 48 | -- 49 | -- > myComputation `except` \ex -> doSomethingWith ex 50 | except :: EffectException s e l => Effect l a -> (e -> Effect l a) -> Effect l a 51 | except x f = sendEffect (Exception (\tag -> exceptWith tag x f)) 52 | 53 | -- | Completely handles an exception effect. 54 | runException :: (EffectBracket s l, Show e) => Effect (Exception s e ':+ l) a -> Effect l (Either e a) 55 | runException effect = do 56 | tag <- newTag show 57 | exceptWith tag 58 | (eliminate (return . Right) (\(Exception f) k -> k (f tag)) effect) 59 | (return . Left) 60 | -------------------------------------------------------------------------------- /src/Control/Effect/Lift.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE CPP #-} 2 | {-# LANGUAGE DataKinds #-} 3 | {-# LANGUAGE FlexibleContexts #-} 4 | {-# LANGUAGE FlexibleInstances #-} 5 | {-# LANGUAGE MultiParamTypeClasses #-} 6 | {-# LANGUAGE TypeFamilies #-} 7 | {-# LANGUAGE TypeOperators #-} 8 | {-# LANGUAGE UndecidableInstances #-} 9 | 10 | #ifdef MTL 11 | {-# OPTIONS_GHC -fno-warn-orphans #-} 12 | #endif 13 | 14 | module Control.Effect.Lift ( 15 | EffectLift, Lift (..), runLift, lift, liftEffect 16 | ) where 17 | 18 | import Control.Monad.Effect 19 | 20 | #ifdef MTL 21 | import Control.Monad.Trans (MonadIO (..)) 22 | 23 | instance EffectLift IO l => MonadIO (Effect l) where 24 | liftIO = lift 25 | #endif 26 | 27 | -- | An effect described by a monad. 28 | newtype Lift m a = Lift { unLift :: m a } 29 | 30 | type instance Is Lift f = IsLift f 31 | 32 | type family IsLift f where 33 | IsLift (Lift m) = 'True 34 | IsLift f = 'False 35 | 36 | class (Monad m, MemberEffect Lift (Lift m) l) => EffectLift m l 37 | instance (Monad m, MemberEffect Lift (Lift m) l) => EffectLift m l 38 | 39 | -- | Lifts a monadic value into an effect. 40 | lift :: EffectLift m l => m a -> Effect l a 41 | lift = send . Lift 42 | 43 | -- | Lifts a monadic value into an effect. 44 | liftEffect :: EffectLift m l => m (Effect l a) -> Effect l a 45 | liftEffect = sendEffect . Lift 46 | 47 | -- | Converts a computation containing only monadic 48 | -- effects into a monadic computation. 49 | runLift :: Monad m => Effect (Lift m ':+ 'Nil) a -> m a 50 | runLift = runEffect . eliminate 51 | (return . return) 52 | (\(Lift m) k -> return $ m >>= runEffect . k) 53 | -------------------------------------------------------------------------------- /src/Control/Effect/List.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE DataKinds #-} 2 | {-# LANGUAGE FlexibleContexts #-} 3 | {-# LANGUAGE FlexibleInstances #-} 4 | {-# LANGUAGE TypeFamilies #-} 5 | {-# LANGUAGE TypeOperators #-} 6 | {-# LANGUAGE UndecidableInstances #-} 7 | {-# OPTIONS_GHC -fno-warn-orphans #-} 8 | 9 | module Control.Effect.List ( 10 | EffectList, List, runList, 11 | choose, never, select, 12 | 13 | CutEffect, Cut, runCut, 14 | cut, cutFalse 15 | ) where 16 | 17 | import Control.Monad.Effect 18 | import Control.Arrow (second) 19 | import Control.Applicative (Alternative (..)) 20 | import Control.Monad (MonadPlus (..), (<=<), join) 21 | 22 | -- | A nondeterminism (backtracking) effect. 23 | newtype List a = List [a] 24 | 25 | type instance Is List f = IsList f 26 | 27 | type family IsList f where 28 | IsList List = 'True 29 | IsList f = 'False 30 | 31 | class Member List l => EffectList l 32 | instance Member List l => EffectList l 33 | 34 | -- | Nondeterministically chooses a value from the input list. 35 | choose :: EffectList l => [a] -> Effect l a 36 | choose = send . List 37 | 38 | -- | Describes a nondeterministic computation that never returns a value. 39 | never :: EffectList l => Effect l a 40 | never = choose [] 41 | 42 | -- | Nondeterministically chooses a value from a list of computations. 43 | select :: EffectList l => [Effect l a] -> Effect l a 44 | select = join . choose 45 | 46 | -- | Obtains all possible values from a computation 47 | -- parameterized by a nondeterminism effect. 48 | runList :: Effect (List ':+ l) a -> Effect l [a] 49 | runList = eliminate (return . return) (\(List xs) k -> fmap concat (mapM k xs)) 50 | 51 | instance EffectList l => Alternative (Effect l) where 52 | empty = never 53 | x <|> y = select [x, y] 54 | 55 | instance EffectList l => MonadPlus (Effect l) where 56 | mzero = empty 57 | mplus = (<|>) 58 | 59 | -- | Describes a Prolog-like cut effect. 60 | -- This effect must be used with the `List` effect. 61 | data Cut a = CutFalse 62 | 63 | class (EffectList l, Member Cut l) => CutEffect l 64 | instance (EffectList l, Member Cut l) => CutEffect l 65 | 66 | -- | Prevents backtracking past the point this value was invoked, 67 | -- in the style of Prolog's "!" operator. 68 | cut :: CutEffect l => Effect l () 69 | cut = return () <|> cutFalse 70 | 71 | -- | Prevents backtracking past the point this value was invoked. 72 | -- Unlike Prolog's "!" operator, `cutFalse` will cause the current 73 | -- computation to fail immediately, instead of when it backtracks. 74 | cutFalse :: CutEffect l => Effect l a 75 | cutFalse = send CutFalse 76 | 77 | -- | Handles the `Cut` effect. `cut`s have no effect beyond 78 | -- the scope of the computation passed to this function. 79 | runCut :: EffectList l => Effect (Cut ':+ l) a -> Effect l a 80 | runCut = choose . snd <=< reifyCut 81 | where 82 | -- Gather the results of a computation into a list (like in runList), but 83 | -- also return a Bool indicating whether a cut was performed in the 84 | -- computation. When we intercept the List effect, we get a continuation and a 85 | -- list of values. If we map the continuation to the list of values, then we 86 | -- get a list of computations. We can now execute each computation one by 87 | -- one, and inspect the Bool after each computation to determine when we 88 | -- should stop. 89 | reifyCut :: EffectList l => Effect (Cut ':+ l) a -> Effect l (Bool, [a]) 90 | reifyCut = 91 | intercept return (\(List xs) k -> runAll (map k xs)) . 92 | eliminate 93 | (\x -> return (False, [x])) 94 | (\CutFalse _ -> return (True, [])) 95 | 96 | runAll [] = return (False, []) 97 | runAll (x:xs) = do 98 | (cutRequested, x') <- x 99 | if cutRequested 100 | then return (True, x') 101 | else fmap (second (x' ++)) (runAll xs) 102 | -------------------------------------------------------------------------------- /src/Control/Effect/Reader.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE CPP #-} 2 | {-# LANGUAGE DataKinds #-} 3 | {-# LANGUAGE FlexibleContexts #-} 4 | {-# LANGUAGE FlexibleInstances #-} 5 | {-# LANGUAGE GADTs #-} 6 | {-# LANGUAGE MultiParamTypeClasses #-} 7 | {-# LANGUAGE TypeFamilies #-} 8 | {-# LANGUAGE TypeOperators #-} 9 | {-# LANGUAGE UndecidableInstances #-} 10 | 11 | #if MTL 12 | {-# OPTIONS_GHC -fno-warn-orphans #-} 13 | #endif 14 | 15 | module Control.Effect.Reader ( 16 | EffectReader, Reader, runReader, 17 | ask, asks, local, 18 | stateReader 19 | ) where 20 | 21 | import Control.Effect.State 22 | import Control.Monad.Effect 23 | 24 | #ifdef MTL 25 | import Data.Type.Row 26 | import qualified Control.Monad.Reader.Class as R 27 | 28 | instance (Member (Reader r) l, Reader r ~ InstanceOf Reader l) => R.MonadReader r (Effect l) where 29 | ask = ask 30 | local = local 31 | reader = asks 32 | #endif 33 | 34 | -- | An effect that provides an implicit environment. 35 | data Reader r a where 36 | Ask :: Reader r r 37 | 38 | type instance Is Reader f = IsReader f 39 | 40 | type family IsReader f where 41 | IsReader (Reader r) = 'True 42 | IsReader f = 'False 43 | 44 | class MemberEffect Reader (Reader r) l => EffectReader r l 45 | instance MemberEffect Reader (Reader r) l => EffectReader r l 46 | 47 | -- | Retrieves the current environment. 48 | ask :: EffectReader r l => Effect l r 49 | ask = send Ask 50 | 51 | -- | Retrieves a value that is a function of the current environment. 52 | asks :: EffectReader r l => (r -> a) -> Effect l a 53 | asks f = fmap f ask 54 | 55 | -- | Runs a computation with a modified environment. 56 | local :: EffectReader r l => (r -> r) -> Effect l a -> Effect l a 57 | local f effect = do 58 | env <- asks f 59 | intercept return (bind env) effect 60 | 61 | -- | Executes a reader computation which obtains 62 | -- its environment value from a state effect. 63 | stateReader :: EffectState s l => Effect (Reader s ':+ l) a -> Effect l a 64 | stateReader = eliminate return (\Ask k -> get >>= k) 65 | 66 | -- | Completely handles a `Reader` effect by providing an 67 | -- environment value to be used throughout the computation. 68 | runReader :: r -> Effect (Reader r ':+ l) a -> Effect l a 69 | runReader env = eliminate return (bind env) 70 | 71 | bind :: r -> Reader r a -> (a -> s) -> s 72 | bind env Ask k = k env 73 | -------------------------------------------------------------------------------- /src/Control/Effect/State.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE CPP #-} 2 | {-# LANGUAGE DataKinds #-} 3 | {-# LANGUAGE FlexibleContexts #-} 4 | {-# LANGUAGE FlexibleInstances #-} 5 | {-# LANGUAGE MultiParamTypeClasses #-} 6 | {-# LANGUAGE TypeFamilies #-} 7 | {-# LANGUAGE TypeOperators #-} 8 | {-# LANGUAGE UndecidableInstances #-} 9 | 10 | #if MTL 11 | {-# OPTIONS_GHC -fno-warn-orphans #-} 12 | #endif 13 | 14 | module Control.Effect.State ( 15 | EffectState, State, runState, 16 | evalState, execState, 17 | get, gets, put, 18 | modify, modify', 19 | state, withState 20 | ) where 21 | 22 | import Control.Monad.Effect 23 | 24 | #ifdef MTL 25 | import qualified Control.Monad.State.Class as S 26 | import Data.Type.Row 27 | 28 | instance (Member (State s) l, State s ~ InstanceOf State l) => S.MonadState s (Effect l) where 29 | get = get 30 | put = put 31 | state = state 32 | #endif 33 | 34 | -- | An effect where a state value is threaded throughout the computation. 35 | newtype State s a = State (s -> (a, s)) 36 | 37 | type instance Is State f = IsState f 38 | 39 | type family IsState f where 40 | IsState (State s) = 'True 41 | IsState f = 'False 42 | 43 | class MemberEffect State (State s) l => EffectState s l 44 | instance MemberEffect State (State s) l => EffectState s l 45 | 46 | -- | Gets the current state. 47 | get :: EffectState s l => Effect l s 48 | get = state $ \s -> (s, s) 49 | 50 | -- | Gets a value that is a function of the current state. 51 | gets :: EffectState s l => (s -> a) -> Effect l a 52 | gets f = fmap f get 53 | 54 | -- | Replaces the current state. 55 | put :: EffectState s l => s -> Effect l () 56 | put x = state $ const ((), x) 57 | 58 | -- | Applies a pure modifier to the state value. 59 | modify :: EffectState s l => (s -> s) -> Effect l () 60 | modify f = get >>= put . f 61 | 62 | -- | Applies a pure modifier to the state value. 63 | -- The modified value is converted to weak head normal form. 64 | modify' :: EffectState s l => (s -> s) -> Effect l () 65 | modify' f = do 66 | x <- get 67 | put $! f x 68 | 69 | -- | Lifts a stateful computation to the `Effect` monad. 70 | state :: EffectState s l => (s -> (a, s)) -> Effect l a 71 | state = send . State 72 | 73 | -- | Runs a computation with a modified state value. 74 | -- 75 | -- prop> withState f x = modify f >> x 76 | withState :: EffectState s l => (s -> s) -> Effect l a -> Effect l a 77 | withState f x = modify f >> x 78 | 79 | -- | Completely handles a `State` effect by providing an 80 | -- initial state, and making the final state explicit. 81 | runState :: s -> Effect (State s ':+ l) a -> Effect l (a, s) 82 | runState = flip $ eliminate 83 | (\x s -> return (x, s)) 84 | (\(State f) k s -> let (x, s') = f s in k x s') 85 | 86 | -- | Completely handles a `State` effect, and discards the final state. 87 | evalState :: s -> Effect (State s ':+ l) a -> Effect l a 88 | evalState s = fmap fst . runState s 89 | 90 | -- | Completely handles a `State` effect, and discards the final value. 91 | execState :: s -> Effect (State s ':+ l) a -> Effect l s 92 | execState s = fmap snd . runState s 93 | -------------------------------------------------------------------------------- /src/Control/Effect/Thread.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE DataKinds #-} 2 | {-# LANGUAGE FlexibleContexts #-} 3 | {-# LANGUAGE FlexibleInstances #-} 4 | {-# LANGUAGE TypeOperators #-} 5 | {-# LANGUAGE UndecidableInstances #-} 6 | 7 | module Control.Effect.Thread ( 8 | EffectThread, Thread, 9 | runMain, runSync, runAsync, 10 | yield, fork, abort, 11 | ) where 12 | 13 | import Control.Effect.Lift 14 | import Control.Monad.Effect 15 | import Control.Monad (void) 16 | import qualified Control.Concurrent as IO 17 | 18 | -- | An effect that describes concurrent computation. 19 | data Thread a = Yield a | Fork a a | Abort 20 | 21 | class Member Thread l => EffectThread l 22 | instance Member Thread l => EffectThread l 23 | 24 | -- | Yields to the next available thread. 25 | yield :: EffectThread l => Effect l () 26 | yield = send (Yield ()) 27 | 28 | -- | Forks a child thread. 29 | fork :: EffectThread l => Effect l () -> Effect l () 30 | fork child = sendEffect $ Fork child (return ()) 31 | 32 | -- | Immediately terminates the current thread. 33 | abort :: EffectThread l => Effect l () 34 | abort = send Abort 35 | 36 | -- | Executes a threaded computation synchronously. 37 | -- Completes when the main thread exits. 38 | runMain :: Effect (Thread ':+ l) () -> Effect l () 39 | runMain = run [] . toAST 40 | where 41 | run auxThreads thread = do 42 | result <- thread 43 | case result of 44 | AbortAST -> return () 45 | YieldAST k -> do 46 | auxThreads' <- runAll auxThreads 47 | run auxThreads' k 48 | ForkAST child parent -> do 49 | auxThreads' <- runAll [child] 50 | run (auxThreads ++ auxThreads') parent 51 | 52 | runAll [] = return [] 53 | runAll (thread:xs) = do 54 | result <- thread 55 | case result of 56 | AbortAST -> runAll xs 57 | YieldAST k -> fmap (k:) (runAll xs) 58 | ForkAST child parent -> fmap (parent:) (runAll (child:xs)) 59 | 60 | -- | Executes a threaded computation synchronously. 61 | -- Does not complete until all threads have exited. 62 | runSync :: Effect (Thread ':+ l) () -> Effect l () 63 | runSync = run . (:[]) . toAST 64 | where 65 | run [] = return () 66 | run (thread:xs) = do 67 | result <- thread 68 | case result of 69 | AbortAST -> run xs 70 | YieldAST k -> run (xs ++ [k]) 71 | ForkAST child parent -> run (child:xs ++ [parent]) 72 | 73 | -- | Executes a threaded computation asynchronously. 74 | runAsync :: Effect (Thread ':+ Lift IO ':+ 'Nil) () -> IO () 75 | runAsync = run . toAST 76 | where 77 | run thread = do 78 | result <- runLift thread 79 | case result of 80 | AbortAST -> return () 81 | YieldAST k -> do 82 | IO.yield 83 | run k 84 | ForkAST child parent -> do 85 | void $ IO.forkIO $ run child 86 | run parent 87 | 88 | data ThreadAST l 89 | = YieldAST (Effect l (ThreadAST l)) 90 | | ForkAST (Effect l (ThreadAST l)) (Effect l (ThreadAST l)) 91 | | AbortAST 92 | 93 | -- Converts a threaded computation into its corresponding AST. This allows 94 | -- different backends to interpret calls to fork/yield/abort as they please. See 95 | -- the implementations of runAsync, runSync, and runMain. 96 | toAST :: Effect (Thread ':+ l) () -> Effect l (ThreadAST l) 97 | toAST = eliminate (\_ -> return AbortAST) bind 98 | where 99 | bind Abort _ = return AbortAST 100 | bind (Yield x) k = return (YieldAST (k x)) 101 | bind (Fork child parent) k = return (ForkAST (k child) (k parent)) 102 | -------------------------------------------------------------------------------- /src/Control/Effect/Witness.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE DataKinds #-} 2 | {-# LANGUAGE FlexibleContexts #-} 3 | {-# LANGUAGE FlexibleInstances #-} 4 | {-# LANGUAGE GADTs #-} 5 | {-# LANGUAGE RankNTypes #-} 6 | {-# LANGUAGE MultiParamTypeClasses #-} 7 | {-# LANGUAGE TypeFamilies #-} 8 | {-# LANGUAGE TypeOperators #-} 9 | {-# LANGUAGE UndecidableInstances #-} 10 | 11 | module Control.Effect.Witness ( 12 | EffectWitness, Witness, runWitness, 13 | Token, newToken 14 | ) where 15 | 16 | import Control.Monad.Effect 17 | import Data.Type.Equality ((:~:) (..), TestEquality (..)) 18 | import Data.Unique (Unique, newUnique) 19 | import System.IO.Unsafe (unsafePerformIO) 20 | import Unsafe.Coerce (unsafeCoerce) 21 | 22 | -- | A unique identifier associated with a type @a@. 23 | -- If two tokens are equal, then so are their associated types. 24 | -- Use `testEquality` to safely cast between types. 25 | newtype Token s a = Token Unique 26 | deriving Eq 27 | 28 | instance TestEquality (Token s) where 29 | testEquality (Token i) (Token j) 30 | | i == j = Just unsafeRefl 31 | | otherwise = Nothing 32 | 33 | unsafeRefl :: a :~: b 34 | unsafeRefl = unsafeCoerce Refl 35 | 36 | -- | An effect describing the generation of unique identifiers. 37 | data Witness s a where 38 | NewToken :: Witness s (Token s a) 39 | 40 | type instance Is Witness f = IsWitness f 41 | 42 | type family IsWitness f where 43 | IsWitness (Witness s) = 'True 44 | IsWitness f = 'False 45 | 46 | class MemberEffect Witness (Witness s) l => EffectWitness s l 47 | instance MemberEffect Witness (Witness s) l => EffectWitness s l 48 | 49 | type family WitnessType l where 50 | WitnessType (Witness s ': l) = s 51 | WitnessType (e ': l) = WitnessType l 52 | 53 | -- | Generates a new, unique `Token`. 54 | newToken :: EffectWitness s l => Effect l (Token s a) 55 | newToken = send NewToken 56 | 57 | -- | Completely handles a `Witness` effect. The Rank-2 quantifier ensures that 58 | -- unique identifiers cannot escape the context in which they were created. 59 | runWitness :: (forall s. Effect (Witness s ':+ l) a) -> Effect l a 60 | runWitness effect = run effect 61 | where 62 | run = eliminate return $ \NewToken k -> 63 | k $ Token $ unsafePerformIO newUnique 64 | -------------------------------------------------------------------------------- /src/Control/Effect/Writer.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE CPP #-} 2 | {-# LANGUAGE DataKinds #-} 3 | {-# LANGUAGE FlexibleContexts #-} 4 | {-# LANGUAGE FlexibleInstances #-} 5 | {-# LANGUAGE GADTs #-} 6 | {-# LANGUAGE MultiParamTypeClasses #-} 7 | {-# LANGUAGE TypeFamilies #-} 8 | {-# LANGUAGE TypeOperators #-} 9 | {-# LANGUAGE UndecidableInstances #-} 10 | 11 | #if MTL 12 | {-# OPTIONS_GHC -fno-warn-orphans #-} 13 | #endif 14 | 15 | module Control.Effect.Writer ( 16 | EffectWriter, Writer, runWriter, 17 | tell, listen, listens, pass, censor, 18 | stateWriter 19 | ) where 20 | 21 | import Control.Monad.Effect 22 | import Control.Arrow (second) 23 | #if !MIN_VERSION_base(4, 8, 0) 24 | import Data.Monoid (Monoid (..)) 25 | #endif 26 | import Control.Effect.State 27 | 28 | #ifdef MTL 29 | import Data.Type.Row 30 | import qualified Control.Monad.Writer.Class as W 31 | 32 | instance (Monoid w, Member (Writer w) l, Writer w ~ InstanceOf Writer l) => W.MonadWriter w (Effect l) where 33 | tell = tell 34 | listen = listen 35 | pass = pass 36 | #endif 37 | 38 | -- | An effect that allows accumulating output. 39 | data Writer w a where 40 | Tell :: w -> Writer w () 41 | 42 | type instance Is Writer f = IsWriter f 43 | 44 | type family IsWriter f where 45 | IsWriter (Writer w) = 'True 46 | IsWriter f = 'False 47 | 48 | class (Monoid w, MemberEffect Writer (Writer w) l) => EffectWriter w l 49 | instance (Monoid w, MemberEffect Writer (Writer w) l) => EffectWriter w l 50 | 51 | -- | Writes a value to the output. 52 | tell :: EffectWriter w l => w -> Effect l () 53 | tell = send . Tell 54 | 55 | -- | Executes a computation, and obtains the writer output. 56 | -- The writer output of the inner computation is still 57 | -- written to the writer output of the outer computation. 58 | listen :: EffectWriter w l => Effect l a -> Effect l (a, w) 59 | listen effect = do 60 | value@(_, output) <- intercept point bind effect 61 | tell output 62 | return value 63 | 64 | -- | Like `listen`, but the writer output is run through a function. 65 | listens :: EffectWriter w l => (w -> b) -> Effect l a -> Effect l (a, b) 66 | listens f = fmap (second f) . listen 67 | 68 | -- | Runs a computation that returns a value and a function, 69 | -- applies the function to the writer output, and then returns the value. 70 | pass :: EffectWriter w l => Effect l (a, w -> w) -> Effect l a 71 | pass effect = do 72 | ((x, f), l) <- listen effect 73 | tell (f l) 74 | return x 75 | 76 | -- | Applies a function to the writer output of a computation. 77 | censor :: EffectWriter w l => (w -> w) -> Effect l a -> Effect l a 78 | censor f effect = pass $ do 79 | a <- effect 80 | return (a, f) 81 | 82 | -- | Executes a writer computation which sends its output to a state effect. 83 | stateWriter :: (Monoid s, EffectState s l) => Effect (Writer s ':+ l) a -> Effect l a 84 | stateWriter = eliminate return (\(Tell l) k -> modify (mappend l) >> k ()) 85 | 86 | -- | Completely handles a writer effect. The writer value must be a `Monoid`. 87 | -- `mempty` is used as an initial value, and `mappend` is used to combine values. 88 | -- Returns the result of the computation and the final output value. 89 | runWriter :: Monoid w => Effect (Writer w ':+ l) a -> Effect l (a, w) 90 | runWriter = eliminate point bind 91 | 92 | point :: Monoid w => a -> Effect l (a, w) 93 | point x = return (x, mempty) 94 | 95 | bind :: Monoid w => Writer w a -> (a -> Effect l (b, w)) -> Effect l (b, w) 96 | bind (Tell l) k = second (mappend l) `fmap` k () 97 | -------------------------------------------------------------------------------- /src/Control/Monad/Effect.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE CPP #-} 2 | {-# LANGUAGE DataKinds #-} 3 | {-# LANGUAGE FlexibleContexts #-} 4 | {-# LANGUAGE FlexibleInstances #-} 5 | {-# LANGUAGE PolyKinds #-} 6 | {-# LANGUAGE RankNTypes #-} 7 | {-# LANGUAGE MultiParamTypeClasses #-} 8 | {-# LANGUAGE TypeFamilies #-} 9 | {-# LANGUAGE TypeOperators #-} 10 | 11 | module Control.Monad.Effect ( 12 | -- * The Effect Monad 13 | Effect, runEffect, 14 | send, sendEffect, 15 | 16 | -- * Effect Handlers 17 | Effectful (EffectsOf), 18 | 19 | eliminate, intercept, 20 | extend, enable, 21 | conceal, reveal, rename, 22 | swap, rotate, 23 | mask, unmask, 24 | 25 | -- * Unions 26 | Union, flatten, unflatten, 27 | 28 | -- * Membership 29 | Member, MemberEffect, Is, 30 | 31 | -- * Effect Rows 32 | Row (..), type (:++), 33 | KnownLength, Inclusive 34 | ) where 35 | 36 | import Data.Union (Union) 37 | import qualified Data.Union as Union 38 | 39 | import Data.Type.Row 40 | 41 | #if !MIN_VERSION_base(4,8,0) 42 | import Control.Applicative (Applicative (..)) 43 | #endif 44 | import Control.Monad (join) 45 | 46 | -- | An effectful computation. An @Effect l a@ may perform any of the effects 47 | -- specified by the list of effects @l@ before returning a result of type @a@. 48 | -- The definition is isomorphic to the following GADT: 49 | -- 50 | -- @ 51 | -- data Effect l a where 52 | -- Done :: a -> Effect l a 53 | -- Side :: `Union` l (Effect l a) -> Effect l a 54 | -- @ 55 | newtype Effect l a = Effect (forall r. (a -> r) -> (forall b. Union l b -> (b -> r) -> r) -> r) 56 | 57 | unEffect :: (a -> r) -> (forall b. Union l b -> (b -> r) -> r) -> Effect l a -> r 58 | unEffect point bind (Effect f) = f point bind 59 | 60 | instance Functor (Effect l) where 61 | fmap f (Effect g) = Effect $ \point -> g (point . f) 62 | 63 | instance Applicative (Effect l) where 64 | pure x = Effect $ \point _ -> point x 65 | Effect f <*> Effect x = Effect $ \point bind -> 66 | f (\f' -> x (point . f') bind) bind 67 | 68 | instance Monad (Effect l) where 69 | return = pure 70 | Effect f >>= g = Effect $ \point bind -> 71 | f (unEffect point bind . g) bind 72 | 73 | -- | Converts an computation that produces no effects into a regular value. 74 | runEffect :: Effect 'Nil a -> a 75 | runEffect (Effect f) = f id Union.absurd 76 | 77 | -- | Executes an effect of type @f@ that produces a return value of type @a@. 78 | send :: Member f l => f a -> Effect l a 79 | send x = Effect $ \point bind -> bind (Union.inject x) point 80 | 81 | -- | Executes an effect of type @f@ that produces a return value of type @r@. 82 | -- Note that a specific instance of this function is of type 83 | -- @Member f l => f (Effect l a) -> Effect l a@, which allows users 84 | -- to send effects parameterized by effects. 85 | sendEffect :: (Member f l, Effectful l r) => f r -> r 86 | sendEffect x = relay (Union.inject x) id 87 | 88 | -- | The class of types which result in an effect. That is: 89 | -- 90 | -- > Effect l r 91 | -- > a -> Effect l r 92 | -- > a -> b -> Effect l r 93 | -- > ... 94 | class l ~ EffectsOf r => Effectful l r where 95 | -- | Determines the effects associated with the return type of a function. 96 | type family EffectsOf r :: Row (* -> *) 97 | 98 | relay :: Union l a -> (a -> r) -> r 99 | 100 | -- Prevents the `Minimal Complete Definition` box from showing. 101 | relay = undefined 102 | 103 | instance Effectful l (Effect l a) where 104 | type EffectsOf (Effect l a) = l 105 | relay u f = join $ Effect $ \point bind -> bind u (point . f) 106 | 107 | instance Effectful l r => Effectful l (a -> r) where 108 | type EffectsOf (a -> r) = EffectsOf r 109 | relay u f y = relay u (\x -> f x y) 110 | 111 | -- | Handles an effect without eliminating it. The second function parameter is 112 | -- passed an effect value and a continuation function. 113 | -- 114 | -- The most common instantiation of this function is: 115 | -- 116 | -- > (a -> Effect l b) -> (f (Effect l b) -> Effect l b) -> Effect l a -> Effect l b 117 | intercept :: (Effectful l r, Member f l) => (a -> r) -> (forall b. f b -> (b -> r) -> r) -> Effect l a -> r 118 | intercept point bind = unEffect point $ \u -> maybe (relay u) bind (Union.project u) 119 | 120 | -- | Completely handles an effect. The second function parameter is passed an 121 | -- effect value and a continuation function. 122 | -- 123 | -- The most common instantiation of this function is: 124 | -- 125 | -- > (a -> Effect l b) -> (f (Effect l b) -> Effect l b) -> Effect (f ': l) a -> Effect l b 126 | eliminate :: Effectful l r => (a -> r) -> (forall b. f b -> (b -> r) -> r) -> Effect (f ':+ l) a -> r 127 | eliminate point bind = unEffect point (either bind relay . Union.pop) 128 | 129 | -- | Adds an arbitrary effect to the head of the effect list. 130 | extend :: Effect l a -> Effect (f ':+ l) a 131 | extend = translate Union.push 132 | 133 | -- | Enables an effect that was previously disabled. 134 | enable :: Effect (f ':- l) a -> Effect l a 135 | enable = translate Union.enable 136 | 137 | -- | Hides an effect @f@ by translating each instance of the effect into an 138 | -- equivalent effect further into the effect list. 139 | -- 140 | -- prop> conceal = eliminate return (\x k -> send x >>= k) 141 | conceal :: Member f l => Effect (f ':+ l) a -> Effect l a 142 | conceal = translate Union.conceal 143 | 144 | -- | Hides an effect @f@ by translating each instance of the effect into an 145 | -- equivalent effect at the head of the effect list. 146 | reveal :: Member f l => Effect l a -> Effect (f ':+ l) a 147 | reveal = translate Union.reveal 148 | 149 | -- | Translates the first effect in the effect list into another effect. 150 | -- 151 | -- prop> rename f = eliminate return (\x k -> send (f x) >>= k) . swap . extend 152 | rename :: (forall r. f r -> g r) -> Effect (f ':+ l) a -> Effect (g ':+ l) a 153 | rename f = translate (either (Union.inject . f) Union.push . Union.pop) 154 | 155 | -- | Reorders the first two effects in a computation. 156 | swap :: Effect (f ':+ g ':+ l) a -> Effect (g ':+ f ':+ l) a 157 | swap = translate Union.swap 158 | 159 | -- | Rotates the first three effects in a computation. 160 | rotate :: Effect (f ':+ g ':+ h ':+ l) a -> Effect (g ':+ h ':+ f ':+ l) a 161 | rotate = translate Union.rotate 162 | 163 | -- | Distributes the sub-effects of a `Union` effect across a computation. 164 | flatten :: Inclusive l => Effect (Union l ':+ m) a -> Effect (l :++ m) a 165 | flatten = translate Union.flatten 166 | 167 | -- | Collects some effects in a computation into a `Union` effect. 168 | unflatten :: KnownLength l => Effect (l :++ m) a -> Effect (Union l ':+ m) a 169 | unflatten = translate Union.unflatten 170 | 171 | translate :: (forall r. Union l r -> Union m r) -> Effect l a -> Effect m a 172 | translate f = unEffect return (relay . f) 173 | 174 | -- | Converts a set of effects @l@ into a single effect @f@. 175 | -- 176 | -- @ mask f = `conceal` . `rename` f . `unflatten` @ 177 | mask :: (KnownLength l, Member f m) => (forall r. Union l r -> f r) -> Effect (l :++ m) a -> Effect m a 178 | mask f = conceal . rename f . unflatten 179 | 180 | -- | Converts an effect @f@ into a set of effects @l@. 181 | -- 182 | -- @ unmask f = `flatten` . `rename` f . `reveal` @ 183 | unmask :: (Inclusive l, Member f m) => (forall r. f r -> Union l r) -> Effect m a -> Effect (l :++ m) a 184 | unmask f = flatten . rename f . reveal 185 | 186 | -- | A refined `Member`ship constraint that can infer @f@ from @l@, given 187 | -- @name@. In order for this to be used, @`Is` name f@ must be defined. 188 | -- For example: 189 | -- 190 | -- > data Reader r a = ... 191 | -- > 192 | -- > type instance Is Reader f = IsReader f 193 | -- > 194 | -- > type IsReader f where 195 | -- > IsReader (Reader r) = True 196 | -- > IsReader f = False 197 | -- > 198 | -- > type ReaderEffect r l = MemberEffect Reader (Reader r) l 199 | -- > 200 | -- > ask :: ReaderEffect r l => Effect l r 201 | -- > ask = ... 202 | -- 203 | -- Given the constraint @ReaderEffect r l@ in the above example, @r@ can be 204 | -- inferred from @l@. 205 | class (Member f l, f ~ InstanceOf name l) => MemberEffect name f l 206 | instance (Member f l, f ~ InstanceOf name l) => MemberEffect name f l 207 | -------------------------------------------------------------------------------- /src/Data/Index.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE DataKinds #-} 2 | {-# LANGUAGE PolyKinds #-} 3 | {-# LANGUAGE ScopedTypeVariables #-} 4 | {-# LANGUAGE TypeOperators #-} 5 | 6 | module Data.Index ( 7 | Index, 8 | zero, index, 9 | absurd, trivial, 10 | swap, rotate, 11 | push, pop, 12 | disable, enable, 13 | conceal, reveal, 14 | prepend, append, split 15 | ) where 16 | 17 | import Data.Type.Row 18 | import Data.Type.Nat 19 | 20 | import Data.Proxy (Proxy (..)) 21 | import Data.Type.Equality ((:~:) (..), TestEquality (..)) 22 | import Unsafe.Coerce (unsafeCoerce) 23 | 24 | newtype Index (l :: Row k) (e :: k) = Index Integer 25 | deriving Show 26 | 27 | instance TestEquality (Index l) where 28 | testEquality (Index i) (Index j) 29 | | i == j = Just (unsafeCoerce Refl) 30 | | otherwise = Nothing 31 | 32 | zero :: Index (e ':+ l) e 33 | zero = Index 0 34 | 35 | index :: forall e l. Member e l => Index l e 36 | index = Index $ natVal (Proxy :: Proxy (IndexOf e l)) 37 | 38 | absurd :: Index 'Nil e -> a 39 | absurd (Index i) = i `seq` error "absurd Index" 40 | 41 | trivial :: Index (e ':+ 'Nil) f -> f :~: e 42 | trivial (Index i) 43 | | i == 0 = unsafeCoerce Refl 44 | | otherwise = error "non-trivial Index" 45 | 46 | size :: forall l proxy. KnownLength l => proxy l -> Integer 47 | size _ = natVal (Proxy :: Proxy (Length l)) 48 | 49 | push :: Index l e -> Index (f ':+ l) e 50 | push (Index i) = Index (i + 1) 51 | 52 | pop :: Index (f ':+ l) e -> Index l e 53 | pop (Index i) = Index (i - 1) 54 | 55 | disable :: Index l e -> Index (f ':- l) e 56 | disable (Index i) = Index (i + 1) 57 | 58 | enable :: Index (f ':- l) e -> Index l e 59 | enable (Index i) = Index (i - 1) 60 | 61 | conceal :: forall e f l. Member f l => Index (f ':+ l) e -> Index l e 62 | conceal (Index i) 63 | | i == 0 = Index j 64 | | otherwise = Index (i - 1) 65 | where 66 | Index j = index :: Index l f 67 | 68 | reveal :: forall e f l. Member f l => Index l e -> Index (f ':+ l) e 69 | reveal (Index i) 70 | | i == j = Index 0 71 | | otherwise = Index (i + 1) 72 | where 73 | Index j = index :: Index l f 74 | 75 | swap :: Index (e ':+ f ':+ l) g -> Index (f ':+ e ':+ l) g 76 | swap (Index i) 77 | | i == 0 = Index 1 78 | | i == 1 = Index 0 79 | | otherwise = Index i 80 | 81 | rotate :: Index (e ':+ f ':+ g ':+ l) h -> Index (f ':+ g ':+ e ':+ l) h 82 | rotate (Index i) 83 | | i == 0 = Index 2 84 | | i == 1 = Index 0 85 | | i == 2 = Index 1 86 | | otherwise = Index i 87 | 88 | prepend :: KnownLength l => proxy l -> Index m e -> Index (l :++ m) e 89 | prepend p (Index i) = Index (i + size p) 90 | 91 | append :: Index l e -> proxy m -> Index (l :++ m) e 92 | append (Index i) _ = Index i 93 | 94 | split :: forall e l m. KnownLength l => Index (l :++ m) e -> Either (Index l e) (Index m e) 95 | split (Index i) 96 | | i < n = Left (Index i) 97 | | otherwise = Right (Index (i - n)) 98 | where 99 | n = size (Proxy :: Proxy l) 100 | -------------------------------------------------------------------------------- /src/Data/Type/Nat.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE DataKinds #-} 2 | {-# LANGUAGE KindSignatures #-} 3 | {-# LANGUAGE ScopedTypeVariables #-} 4 | 5 | module Data.Type.Nat ( 6 | Nat (..), KnownNat (..) 7 | ) where 8 | 9 | import Data.Proxy (Proxy (..)) 10 | 11 | data Nat = Zero | Succ Nat 12 | 13 | class KnownNat (n :: Nat) where 14 | natVal :: proxy n -> Integer 15 | 16 | instance KnownNat 'Zero where 17 | natVal _ = 0 18 | 19 | instance KnownNat n => KnownNat ('Succ n) where 20 | natVal _ = 1 + natVal (Proxy :: Proxy n) 21 | -------------------------------------------------------------------------------- /src/Data/Type/Row.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE DataKinds #-} 2 | {-# LANGUAGE FlexibleContexts #-} 3 | {-# LANGUAGE FlexibleInstances #-} 4 | {-# LANGUAGE MultiParamTypeClasses #-} 5 | {-# LANGUAGE PolyKinds #-} 6 | {-# LANGUAGE TypeFamilies #-} 7 | {-# LANGUAGE TypeOperators #-} 8 | {-# LANGUAGE UndecidableInstances #-} 9 | 10 | module Data.Type.Row ( 11 | Row (..), (:++), 12 | Length, KnownLength, 13 | IndexOf, Member, 14 | Inclusive, 15 | Is, InstanceOf 16 | ) where 17 | 18 | import Data.Type.Nat 19 | import Data.Type.Bool (If) 20 | 21 | infixr 5 :+, :-, :++ 22 | 23 | -- | A type level list with explicit removals. 24 | data Row a 25 | = Nil -- ^ The empty list. 26 | | a :+ Row a -- ^ Prepends an element (cons). 27 | | a :- Row a -- ^ Deletes the first instance an element. 28 | 29 | -- | Appends two type level `Row`s. 30 | type family l :++ m where 31 | 'Nil :++ l = l 32 | (e ':+ l) :++ m = e ':+ l :++ m 33 | (e ':- l) :++ m = e ':- l :++ m 34 | 35 | -- | Returns the length of the `Row` @l@. 36 | type family Length l where 37 | Length 'Nil = 'Zero 38 | Length (h ':+ t) = 'Succ (Length t) 39 | Length (h ':- t) = 'Succ (Length t) 40 | 41 | -- | The class of `Row`s with statically known lengths. 42 | class KnownNat (Length l) => KnownLength l 43 | instance KnownNat (Length l) => KnownLength l 44 | 45 | -- | Returns the index of the first instance of @e@ in the `Row` @l@. 46 | type IndexOf e l = NthIndexOf 'Zero e l 47 | 48 | type family NthIndexOf n e l where 49 | NthIndexOf 'Zero e (e ':+ l) = 'Zero 50 | NthIndexOf ('Succ n) e (e ':+ l) = 'Succ (NthIndexOf n e l) 51 | NthIndexOf n e (f ':+ l) = 'Succ (NthIndexOf n e l) 52 | NthIndexOf n e (e ':- l) = 'Succ (NthIndexOf ('Succ n) e l) 53 | NthIndexOf n e (f ':- l) = 'Succ (NthIndexOf n e l) 54 | 55 | -- | A constraint specifying that @e@ is a member of the `Row` @l@. 56 | class KnownNat (IndexOf e l) => Member e l 57 | instance KnownNat (IndexOf e l) => Member e l 58 | 59 | -- | The class of `Row`s that do not contain deletions (`':-`). 60 | class KnownLength l => Inclusive l 61 | instance Inclusive 'Nil 62 | instance Inclusive l => Inclusive (e ':+ l) 63 | 64 | -- | Returns a boolean value indicating whether @f@ belongs to the group of 65 | -- effects identified by @name@. This allows `MemberEffect` to infer the 66 | -- associated types for arbitrary effects. 67 | type family Is (name :: k) (f :: * -> *) :: Bool 68 | 69 | type InstanceOf name l = InstanceOfNone name '[] l 70 | 71 | -- Any instance of name in l but not in ex. 72 | type family InstanceOfNone name ex l where 73 | InstanceOfNone name ex (f ':- l) = InstanceOfNone name (f ': ex) l 74 | InstanceOfNone name ex (f ':+ l) = 75 | If (Is name f) 76 | (If (Elem f ex) (InstanceOfNone name (Remove f ex) l) f) 77 | (InstanceOfNone name ex l) 78 | 79 | type family Elem e l where 80 | Elem e '[] = 'False 81 | Elem e (e ': l) = 'True 82 | Elem e (f ': l) = Elem e l 83 | 84 | type family Remove e l where 85 | Remove e (e ': l) = l 86 | Remove e (f ': l) = f ': Remove e l 87 | -------------------------------------------------------------------------------- /src/Data/Union.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE DataKinds #-} 2 | {-# LANGUAGE EmptyCase #-} 3 | {-# LANGUAGE GADTs #-} 4 | {-# LANGUAGE TypeOperators #-} 5 | 6 | module Data.Union ( 7 | Union, absurd, 8 | wrap, unwrap, 9 | inject, project, 10 | swap, rotate, 11 | push, pop, 12 | enable, disable, 13 | conceal, reveal, 14 | flatten, unflatten 15 | ) where 16 | 17 | import Data.Index (Index) 18 | import qualified Data.Index as Index 19 | 20 | import Data.Type.Row 21 | import Data.Proxy (Proxy (..)) 22 | import Data.Type.Equality ((:~:) (..), apply, castWith, gcastWith, testEquality) 23 | 24 | -- | Represents a union of the list of type constructors in @l@ parameterized 25 | -- by @a@. As an effect, it represents the union of each type constructor's 26 | -- corresponding effect. From the user's perspective, it provides a way to 27 | -- encapsulate multiple effects. 28 | data Union l a where 29 | Union :: Index l f -> f a -> Union l a 30 | 31 | absurd :: Union 'Nil a -> b 32 | absurd (Union i _) = Index.absurd i 33 | 34 | wrap :: f a -> Union (f ':+ l) a 35 | wrap = inject 36 | 37 | unwrap :: Union (f ':+ 'Nil) a -> f a 38 | unwrap (Union i x) = gcastWith (Index.trivial i) x 39 | 40 | inject :: Member f l => f a -> Union l a 41 | inject = Union Index.index 42 | 43 | project :: Member f l => Union l a -> Maybe (f a) 44 | project (Union i x) = fmap (\refl -> castWith (apply refl Refl) x) mRefl 45 | where 46 | mRefl = testEquality i Index.index 47 | 48 | swap :: Union (f ':+ g ':+ l) a -> Union (g ':+ f ':+ l) a 49 | swap (Union i x) = Union (Index.swap i) x 50 | 51 | rotate :: Union (f ':+ g ':+ h ':+ l) a -> Union (g ':+ h ':+ f ':+ l) a 52 | rotate (Union i x) = Union (Index.rotate i) x 53 | 54 | push :: Union l a -> Union (f ':+ l) a 55 | push (Union i x) = Union (Index.push i) x 56 | 57 | pop :: Union (f ':+ l) a -> Either (f a) (Union l a) 58 | pop (Union i x) = 59 | case testEquality i Index.zero of 60 | Just Refl -> Left x 61 | Nothing -> Right (Union (Index.pop i) x) 62 | 63 | enable :: Union (f ':- l) a -> Union l a 64 | enable (Union i x) = Union (Index.enable i) x 65 | 66 | disable :: Member f l => Union l a -> Either (f a) (Union (f ':- l) a) 67 | disable u@(Union i x) = 68 | case project u of 69 | Just r -> Left r 70 | Nothing -> Right (Union (Index.disable i) x) 71 | 72 | conceal :: Member f l => Union (f ':+ l) a -> Union l a 73 | conceal (Union i x) = Union (Index.conceal i) x 74 | 75 | reveal :: Member f l => Union l a -> Union (f ':+ l) a 76 | reveal (Union i x) = Union (Index.reveal i) x 77 | 78 | flatten :: Inclusive l => Union (Union l ':+ m) a -> Union (l :++ m) a 79 | flatten = flatten' Proxy Proxy . pop 80 | where 81 | flatten' :: KnownLength l => proxy l -> proxy m -> Either (Union l a) (Union m a) -> Union (l :++ m) a 82 | flatten' _ p (Left (Union i x)) = Union (Index.append i p) x 83 | flatten' p _ (Right (Union i x)) = Union (Index.prepend p i) x 84 | 85 | unflatten :: KnownLength l => Union (l :++ m) a -> Union (Union l ':+ m) a 86 | unflatten (Union i x) = 87 | case Index.split i of 88 | Left j -> Union Index.zero (Union j x) 89 | Right j -> Union (Index.push j) x 90 | --------------------------------------------------------------------------------