├── ChangeLog.md ├── LICENSE ├── README.md ├── Setup.hs ├── mpeff.cabal ├── package.yaml ├── src └── Control │ └── Mp │ ├── Eff.hs │ └── Util.hs └── stack.yaml /ChangeLog.md: -------------------------------------------------------------------------------- 1 | # 0.1.0.0 2 | 3 | * Initial release. 4 | -------------------------------------------------------------------------------- /LICENSE: -------------------------------------------------------------------------------- 1 | Copyright (c) 2020, Microsoft Research, Ningning Xie, Daan Leijen 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 Author name here 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 | # MpEff: Efficient effect handlers based on Evidence Passing Semantics 2 | 3 | Efficient effect handlers based on Evidence Passing Semantics. The implementation 4 | is based on 5 | 6 | _Generalized Evidence Passing for Effect Handlers_, Ningning Xie and Daan Leijen, 2021 [(pdf)](https://www.microsoft.com/en-us/research/publication/generalized-evidence-passing-for-effect-handlers/). 7 | 8 | The implementation is closely based on the [Ev.Eff](https://hackage.haskell.org/package/eveff) 9 | library described in detail in 10 | 11 | _Effect Handlers in Haskell, Evidently_, Ningning Xie and Daan Leijen, Haskell 2020 [(pdf)](https://www.microsoft.com/en-us/research/publication/effect-handlers-in-haskell-evidently). 12 | 13 | The _Mp.Eff_ and _Ev.Eff_ libraries expose the exact same interface, but 14 | the _Mp.Eff_ library can express full effect handler semantics, including non-scoped resumptions -- 15 | it is slightly slower though (see the 2021 paper for benchmarks and a detailed comparison). 16 | 17 | Installation: 18 | 19 | * First install [stack](https://docs.haskellstack.org) 20 | * Build with `> stack build` 21 | 22 | An example of defining and using a `Reader` effect: 23 | 24 | ```Haskell 25 | {-# LANGUAGE TypeOperators, FlexibleContexts, Rank2Types #-} 26 | import Control.Mp.Eff 27 | 28 | -- A @Reader@ effect definition with one operation @ask@ of type @()@ to @a@. 29 | data Reader a e ans = Reader{ ask :: Op () a e ans } 30 | 31 | greet :: (Reader String :? e) => Eff e String 32 | greet = do s <- perform ask () 33 | return ("hello " ++ s) 34 | 35 | test :: String 36 | test = runEff $ 37 | handler (Reader{ ask = value "world" }) $ -- @:: Reader String () Int@ 38 | do s <- greet -- executes in context @:: Eff (Reader String :* ()) Int@ 39 | return (length s) 40 | ``` 41 | 42 | Enjoy, 43 | 44 | Ningning Xie and Daan Leijen, Mar 2021. 45 | -------------------------------------------------------------------------------- /Setup.hs: -------------------------------------------------------------------------------- 1 | import Distribution.Simple 2 | main = defaultMain 3 | -------------------------------------------------------------------------------- /mpeff.cabal: -------------------------------------------------------------------------------- 1 | cabal-version: 1.12 2 | 3 | -- This file has been generated from package.yaml by hpack version 0.33.0. 4 | -- 5 | -- see: https://github.com/sol/hpack 6 | -- 7 | -- hash: b8ecf1544cc419d434acb5067f25bfdb4ba919f6db167c0d989bd35945ae61ee 8 | 9 | name: mpeff 10 | version: 0.1.0.0 11 | synopsis: Efficient effect handlers based on evidence-passing semantics 12 | description: See the "Control.Mp.Eff" module or README.md for further information 13 | category: Control, Effect 14 | homepage: https://github.com/xnning/mpeff#readme 15 | bug-reports: https://github.com/xnning/mpeff/issues 16 | author: Ningning Xie, Daan Leijen 17 | maintainer: xnning@hku.hk;daan@microsoft.com 18 | copyright: (c) 2020, Microsoft Research, Ningning Xie, Daan Leijen 19 | license: MIT 20 | license-file: LICENSE 21 | build-type: Simple 22 | extra-source-files: 23 | README.md 24 | ChangeLog.md 25 | 26 | source-repository head 27 | type: git 28 | location: https://github.com/xnning/mpeff 29 | 30 | library 31 | exposed-modules: 32 | Control.Mp.Eff 33 | Control.Mp.Util 34 | other-modules: 35 | Paths_mpeff 36 | hs-source-dirs: 37 | src 38 | ghc-options: -O2 -fspec-constr-keen 39 | build-depends: 40 | base >=4.7 && <5 41 | , ghc-prim 42 | , primitive 43 | default-language: Haskell2010 44 | -------------------------------------------------------------------------------- /package.yaml: -------------------------------------------------------------------------------- 1 | name: mpeff 2 | version: 0.1.0.0 3 | github: "xnning/mpeff" 4 | license: MIT 5 | author: "Ningning Xie, Daan Leijen" 6 | maintainer: "xnning@hku.hk;daan@microsoft.com" 7 | copyright: "(c) 2020, Microsoft Research, Ningning Xie, Daan Leijen" 8 | 9 | extra-source-files: 10 | - README.md 11 | - ChangeLog.md 12 | 13 | # Metadata used when publishing your package 14 | synopsis: Efficient effect handlers based on evidence-passing semantics 15 | category: Control, Effect 16 | 17 | # To avoid duplicated efforts in documentation and dealing with the 18 | # complications of embedding Haddock markup inside cabal files, it is 19 | # common to point users to the README.md file. 20 | description: 21 | See the "Control.Mp.Eff" module or README.md for further information 22 | 23 | 24 | dependencies: 25 | - base >= 4.7 && < 5 26 | - primitive 27 | - ghc-prim 28 | 29 | library: 30 | source-dirs: src 31 | ghc-options: 32 | - -O2 -fspec-constr-keen 33 | -------------------------------------------------------------------------------- /src/Control/Mp/Eff.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE TypeOperators, -- h :* e (looks nice but not required) 2 | ConstraintKinds, -- type (h ?: e) = In h e (looks nice but not required) 3 | FlexibleInstances, -- instance Sub () e (non type variable in head) 4 | FlexibleContexts, -- (State Int ?: e) => ... (non type variable argument) 5 | DataKinds, TypeFamilies, -- type family HEqual h h' :: Bool 6 | UndecidableInstances, -- InEq (HEqual h h') h h' e => ... (duplicate instance variable) 7 | ScopedTypeVariables, 8 | GADTs, 9 | MultiParamTypeClasses, 10 | Rank2Types 11 | #-} 12 | {-| 13 | Description : Efficient effect handlers based on Evidence Passing Semantics 14 | Copyright : (c) 2021, Ningning Xie, Daan Leijen 15 | License : MIT 16 | Maintainer : xnning@hku.hk; daan@microsoft.com 17 | Stability : Experimental 18 | 19 | Efficient effect handlers based on Evidence passing semantics. The implementation 20 | is based on /"Generalized Evidence Passing for Effect Handlers"/, Ningning Xie and Daan Leijen, 2021 [(pdf)](https://www.microsoft.com/en-us/research/publication/generalized-evidence-passing-for-effect-handlers/), 21 | The implementation is closely based on the [Ev.Eff](https://hackage.haskell.org/package/eveff) 22 | library described in detail in /"Effect Handlers in Haskell, Evidently"/, Ningning Xie and Daan Leijen, Haskell 2020 [(pdf)](https://www.microsoft.com/en-us/research/publication/effect-handlers-in-haskell-evidently). 23 | The _Mp.Eff_ and _Ev.Eff_ libraries expose the exact same interface, but 24 | the _Mp.Eff_ library can express full effect handler semantics, including non-scoped resumptions -- 25 | it is slightly slower though (see the 2021 paper for benchmarks and a detailed comparison). 26 | 27 | An example of defining and using a @Reader@ effect: 28 | 29 | @ 30 | \{\-\# LANGUAGE TypeOperators, FlexibleContexts, Rank2Types \#\-\} 31 | import Control.Mp.Eff 32 | 33 | -- A @Reader@ effect definition with one operation @ask@ of type @()@ to @a@. 34 | data Reader a e ans = Reader{ ask :: `Op` () a e ans } 35 | 36 | greet :: (Reader String `:?` e) => `Eff` e String 37 | greet = do s <- `perform` ask () 38 | return ("hello " ++ s) 39 | 40 | test :: String 41 | test = `runEff` $ 42 | `handler` (Reader{ ask = `value` "world" }) $ -- @:: Reader String () Int@ 43 | do s <- greet -- executes in context @:: `Eff` (Reader String `:*` ()) Int@ 44 | return (length s) 45 | @ 46 | 47 | Enjoy, 48 | 49 | Ningning Xie and Daan Leijen, Mar 2021. 50 | 51 | -} 52 | module Control.Mp.Eff( 53 | -- * Effect monad 54 | Eff 55 | , runEff -- :: Eff () a -> a 56 | 57 | -- * Effect context 58 | , (:?) -- h :? e, is h in e? 59 | , (:*) -- h :* e, cons h in front of e 60 | -- , In -- alias for :? 61 | 62 | -- * Perform and Handlers 63 | , perform -- :: (h :? e) => (forall e' ans. h e' ans -> Op a b e' ans) -> a -> Eff e b 64 | , handler -- :: h e ans -> Eff (h :* e) ans -> Eff e ans 65 | , handlerRet -- :: (ans -> b) -> h e b -> Eff (h :* e) ans -> Eff e b 66 | , handlerHide -- :: h (h' :* e) ans -> Eff (h :* e) ans -> Eff (h' :* e) ans 67 | , mask -- :: Eff e ans -> Eff (h :* e) ans 68 | 69 | -- * Defining operations 70 | , Op 71 | , value -- :: a -> Op () a e ans 72 | , function -- :: (a -> Eff e b) -> Op a b e ans 73 | , except -- :: (a -> Eff e ans) -> Op a b e ans 74 | , operation -- :: (a -> (b -> Eff e ans)) -> Op a b e ans 75 | 76 | -- * Local state 77 | , Local -- Local a e ans 78 | 79 | , local -- :: a -> Eff (Local a :* e) ans -> Eff e ans 80 | , localRet -- :: a -> (ans -> a -> b) -> Eff (Local a :* e) ans -> Eff e b 81 | , handlerLocal -- :: a -> h (Local a :* e) ans -> Eff (h :* e) ans -> Eff e ans 82 | , handlerLocalRet -- :: a -> (ans -> a -> b) -> h (Local a :* e) b -> Eff (h :* e) ans -> Eff e b 83 | 84 | , lget -- :: (Local a :? e) => Eff e a 85 | , lput -- :: (Local a :? e) => a -> Eff e () 86 | , lmodify -- :: (Local a :? e) => (a -> a) -> Eff e () 87 | 88 | , localGet -- :: Eff (Local a :* e) a 89 | , localPut -- :: a -> Eff (Local a :* e) () 90 | , localModify -- :: (a -> a) -> Eff (Local a :* e) a 91 | 92 | ) where 93 | 94 | import Prelude hiding (read,flip) 95 | import Control.Monad( ap, liftM ) 96 | import Data.Type.Equality( (:~:)( Refl ) ) 97 | import Control.Monad.Primitive 98 | 99 | ------------------------------------------------------- 100 | -- Assume some way to generate a fresh prompt marker 101 | -- associated with specific effect and answer type. 102 | ------------------------------------------------------- 103 | import Unsafe.Coerce (unsafeCoerce) 104 | import System.IO.Unsafe ( unsafePerformIO ) 105 | import Data.IORef 106 | 107 | -- an abstract marker 108 | data Marker (h:: * -> * -> *) e a = Marker !Integer 109 | 110 | instance Show (Marker h e a) where 111 | show (Marker i) = show i 112 | 113 | -- if markers match, their types are the same 114 | mmatch :: Marker h e a -> Marker h' e' b -> Maybe ((h e a, a, e) :~: (h' e' b, b, e')) 115 | mmatch (Marker i) (Marker j) | i == j = Just (unsafeCoerce Refl) 116 | mmatch _ _ = Nothing 117 | 118 | {-# NOINLINE unique #-} 119 | unique :: IORef Integer 120 | unique = unsafePerformIO (newIORef 0) 121 | 122 | -- evaluate a action with a fresh marker 123 | {-# NOINLINE freshMarker #-} 124 | freshMarker :: (Marker h e a -> Eff e a) -> Eff e a 125 | freshMarker f 126 | = let m = unsafePerformIO $ 127 | do i <- readIORef unique; 128 | writeIORef unique (i+1); 129 | return i 130 | in seq m (f (Marker m)) 131 | 132 | ------------------------------------------------------- 133 | -- The handler context 134 | ------------------------------------------------------- 135 | infixr 5 :* 136 | 137 | data (h :: * -> * -> *) :* e 138 | 139 | data Context e where 140 | CCons :: !(Marker h e' ans) -> !(h e' ans) -> !(ContextT e e') -> !(Context e) -> Context (h :* e) 141 | CNil :: Context () 142 | 143 | data ContextT e e' where 144 | CTCons :: !(Marker h e' ans) -> !(h e' ans) -> !(ContextT e e') -> ContextT e (h :* e) 145 | CTId :: ContextT e e 146 | -- CTComp :: ContextT e'' e' -> ContextT e e'' -> ContextT e e' 147 | -- CTFun :: !(Context e -> Context e') -> ContextT e e' 148 | 149 | -- apply a context transformer 150 | applyT :: ContextT e e' -> Context e -> Context e' 151 | applyT (CTCons m h g) ctx = CCons m h g ctx 152 | applyT (CTId) ctx = ctx 153 | --applyT (CTComp c1 c2) ctx = applyT c1 (applyT c2 ctx) 154 | --applyT (CTFun f) ctx = f ctx 155 | 156 | -- the tail of a context 157 | ctail :: Context (h :* e) -> Context e 158 | ctail (CCons _ _ _ ctx) = ctx 159 | 160 | ------------------------------------------------------- 161 | -- The Multi Prompt control monad 162 | -- ans: the answer type, i.e. the type of the handler/prompt context. 163 | -- e' : the answer effect, i.e. the effect in the handler/prompt context. 164 | -- b : the result type of the operation 165 | ------------------------------------------------------- 166 | data Ctl e a = Pure { result :: !a } 167 | | forall h b e' ans. 168 | Control{ marker :: Marker h e' ans, -- prompt marker to yield to (in type context `::ans`) 169 | op :: !((b -> Eff e' ans) -> Eff e' ans), -- the final action, just needs the resumption (:: b -> Eff e' ans) to be evaluated. 170 | cont :: !(b -> Eff e a) } -- the (partially) build up resumption; (b -> Eff e a) :~: (b -> Eff e' ans)` by the time we reach the prompt 171 | 172 | 173 | newtype Eff e a = Eff { unEff :: Context e -> Ctl e a } 174 | 175 | {-# INLINE lift #-} 176 | lift :: Ctl e a -> Eff e a 177 | lift ctl = Eff (\ctx -> ctl) 178 | 179 | {-# INLINE ctxMap #-} 180 | ctxMap :: (Context e' -> Context e) -> Eff e a -> Eff e' a 181 | ctxMap f eff = Eff (\ctx -> ctxMapCtl f $ unEff eff (f ctx)) 182 | 183 | {-# INLINE ctxMapCtl #-} 184 | ctxMapCtl :: (Context e' -> Context e) -> Ctl e a -> Ctl e' a 185 | ctxMapCtl f (Pure x) = Pure x 186 | ctxMapCtl f (Control m op cont) = Control m op (\b -> ctxMap f (cont b)) 187 | 188 | {-# INLINE hideSecond #-} 189 | hideSecond :: Eff (h :* e) a -> Eff (h :* h' :* e) a 190 | hideSecond eff = ctxMap (\(CCons m h CTId (CCons m' h' g' ctx)) -> 191 | CCons m h (CTCons m' h' g') ctx) eff 192 | 193 | under :: In h e => Marker h e' ans -> Context e' -> Eff e' b -> Eff e b 194 | under m ctx (Eff eff) = Eff (\_ -> case eff ctx of 195 | Pure x -> Pure x 196 | Control n op cont -> Control n op (resumeUnder m ctx cont)) 197 | -- Control n op cont -> Control n op (under m ctx . cont)) -- wrong 198 | 199 | resumeUnder :: forall h a b e e' ans. In h e => Marker h e' ans -> Context e' -> (b -> Eff e' a) -> (b -> Eff e a) 200 | resumeUnder m ctx cont x 201 | = withSubContext $ \(SubContext (CCons m' h' g' ctx') :: SubContext h) -> 202 | case mmatch m m' of 203 | Just Refl -> under m (applyT g' ctx') (cont x) 204 | Nothing -> error "EffEv.resumeUnder: marker does not match anymore (this should never happen?)" 205 | 206 | 207 | instance Functor (Eff e) where 208 | fmap = liftM 209 | instance Applicative (Eff e) where 210 | pure = return 211 | (<*>) = ap 212 | instance Monad (Eff e) where 213 | return x = Eff (\evv -> Pure x) 214 | (>>=) = bind 215 | 216 | -- start yielding (with an initially empty continuation) 217 | {-# INLINE yield #-} 218 | yield :: Marker h e ans -> ((b -> Eff e ans) -> Eff e ans) -> Eff e' b 219 | yield m op = Eff (\ctx -> Control m op pure) 220 | 221 | {-# INLINE kcompose #-} 222 | kcompose :: (b -> Eff e c) -> (a -> Eff e b) -> a -> Eff e c -- Kleisli composition 223 | kcompose g f x = 224 | case f x of 225 | -- bind (f x) g 226 | Eff eff -> Eff (\ctx -> case eff ctx of 227 | Pure x -> unEff (g x) ctx 228 | Control m op cont -> Control m op (g `kcompose` cont)) 229 | 230 | {-# INLINE bind #-} 231 | bind :: Eff e a -> (a -> Eff e b) -> Eff e b 232 | bind (Eff eff) f 233 | = Eff (\ctx -> case eff ctx of 234 | Pure x -> unEff (f x) ctx 235 | Control m op cont -> Control m op (f `kcompose` cont)) -- keep yielding with an extended continuation 236 | 237 | instance Functor (Ctl e) where 238 | fmap = liftM 239 | instance Applicative (Ctl e) where 240 | pure = return 241 | (<*>) = ap 242 | instance Monad (Ctl e) where 243 | return x = Pure x 244 | Pure x >>= f = f x 245 | (Control m op cont) >>= f 246 | = Control m op (f `kcompose2` cont) 247 | 248 | kcompose2 :: (b -> Ctl e c) -> (a -> Eff e b) -> a -> Eff e c 249 | kcompose2 g f x 250 | = Eff $ \ctx -> case unEff (f x) ctx of 251 | Pure x -> g x 252 | Control m op cont -> Control m op (g `kcompose2` cont) 253 | 254 | 255 | -- use a prompt with a unique marker (and handle yields to it) 256 | {-# INLINE prompt #-} 257 | prompt :: Marker h e ans -> h e ans -> Eff (h :* e) ans -> Eff e ans 258 | prompt m h (Eff eff) = Eff $ \ctx -> 259 | case (eff (CCons m h CTId ctx)) of -- add handler to the context 260 | Pure x -> Pure x 261 | Control n op cont -> 262 | let cont' x = prompt m h (cont x) in -- extend the continuation with our own prompt 263 | case mmatch m n of 264 | Nothing -> Control n op cont' -- keep yielding (but with the extended continuation) 265 | Just Refl -> unEff (op cont') ctx -- found our prompt, invoke `op` (under the context `ctx`). 266 | -- Note: `Refl` proves `a ~ ans` and `e ~ e'` (the existential `ans,e'` in Control) 267 | 268 | {-# INLINE handler #-} 269 | handler :: h e ans -> Eff (h :* e) ans -> Eff e ans 270 | handler h action 271 | = freshMarker $ \m -> prompt m h action 272 | 273 | -- Run a control monad 274 | runEff :: Eff () a -> a 275 | runEff (Eff eff) = case eff CNil of 276 | Pure x -> x 277 | Control _ _ _ -> error "Unhandled operation" -- can never happen 278 | 279 | {-# INLINE handlerRet #-} 280 | handlerRet :: (ans -> a) -> h e a -> Eff (h :* e) ans -> Eff e a 281 | handlerRet ret h action 282 | = handler h (do x <- action; return (ret x)) 283 | 284 | {-# INLINE handlerHide #-} 285 | handlerHide :: h (h' :* e) ans -> Eff (h :* e) ans -> Eff (h' :* e) ans 286 | handlerHide h action 287 | = handler h (hideSecond action) 288 | 289 | {-# INLINE handlerHideRetEff #-} 290 | handlerHideRetEff :: (ans -> Eff (h' :* e) b) -> h (h' :* e) b -> Eff (h :* e) ans -> Eff (h' :* e) b 291 | handlerHideRetEff ret h action 292 | = handler h (do x <- hideSecond action; mask (ret x)) 293 | 294 | -- | Mask the top effect handler in the give action (i.e. if a operation is performed 295 | -- on an @h@ effect inside @e@ the top handler is ignored). 296 | mask :: Eff e ans -> Eff (h :* e) ans 297 | mask eff = ctxMap ctail eff 298 | 299 | 300 | --------------------------------------------------------- 301 | -- 302 | --------------------------------------------------------- 303 | 304 | type h :? e = In h e 305 | 306 | data SubContext h = forall e. SubContext !(Context (h:* e)) 307 | 308 | class In h e where 309 | subContext :: Context e -> SubContext h 310 | 311 | instance (InEq (HEqual h h') h h' ctx) => In h (h' :* ctx) where 312 | subContext = subContextEq 313 | 314 | type family HEqual (h :: * -> * -> *) (h' :: * -> * -> *) :: Bool where 315 | HEqual h h = 'True 316 | HEqual h h' = 'False 317 | 318 | class (iseq ~ HEqual h h') => InEq iseq h h' e where 319 | subContextEq :: Context (h' :* e) -> SubContext h 320 | 321 | instance (h ~ h') => InEq 'True h h' e where 322 | subContextEq ctx = SubContext ctx 323 | 324 | instance ('False ~ HEqual h h', In h e) => InEq 'False h h' e where 325 | subContextEq ctx = subContext (ctail ctx) 326 | 327 | 328 | {-# INLINE withSubContext #-} 329 | withSubContext :: (h :? e) => (SubContext h -> Eff e a) -> Eff e a 330 | withSubContext action 331 | = do ctx <- Eff Pure 332 | action (subContext ctx) 333 | 334 | 335 | ------------------------------------ 336 | -- Operations 337 | ------------------------------------- 338 | 339 | -- | The abstract type of operations of type @a@ to @b@, for a handler 340 | -- defined in an effect context @e@ and answer type @ans@. 341 | data Op a b e ans = Op { applyOp:: !(forall h e'. In h e' => Marker h e ans -> Context e -> a -> Eff e' b) } 342 | 343 | 344 | -- Given evidence and an operation selector, perform the operation 345 | {-# INLINE perform #-} 346 | perform :: In h e => (forall e' ans. h e' ans -> Op a b e' ans) -> a -> Eff e b 347 | perform selectOp x 348 | = withSubContext $ \(SubContext (CCons m h g ctx)) -> 349 | applyOp (selectOp h) m (applyT g ctx) x 350 | 351 | -- | Create an operation that always resumes with a constant value (of type @a@). 352 | -- (see also the `perform` example). 353 | value :: a -> Op () a e ans 354 | value x = function (\() -> return x) 355 | 356 | -- | Create an operation that takes an argument of type @a@ and always resumes with a result of type @b@. 357 | -- These are called /tail-resumptive/ operations and are implemented more efficient than 358 | -- general operations as they can execute /in-place/ (instead of yielding to the handler). 359 | -- Most operations are tail-resumptive. (See also the `handlerLocal` example). 360 | function :: (a -> Eff e b) -> Op a b e ans 361 | function f = Op (\m ctx x -> under m ctx (f x)) 362 | 363 | -- | Create an fully general operation from type @a@ to @b@. 364 | -- the function @f@ takes the argument, and a /resumption/ function of type @b -> `Eff` e ans@ 365 | -- that can be called to resume from the original call site. For example: 366 | -- 367 | -- @ 368 | -- data Amb e ans = Amb { flip :: forall b. `Op` () Bool e ans } 369 | -- 370 | -- xor :: (Amb `:?` e) => `Eff` e Bool 371 | -- xor = do x <- `perform` flip () 372 | -- y <- `perform` flip () 373 | -- return ((x && not y) || (not x && y)) 374 | -- 375 | -- solutions :: `Eff` (Amb `:*` e) a -> `Eff` e [a] 376 | -- solutions = `handlerRet` (\\x -> [x]) $ 377 | -- Amb{ flip = `operation` (\\() k -> do{ xs <- k True; ys <- k False; return (xs ++ ys)) }) } 378 | -- @ 379 | operation :: (a -> (b -> Eff e ans) -> Eff e ans) -> Op a b e ans 380 | operation f = Op (\m ctx x -> yield m (\ctlk -> f x ctlk)) 381 | 382 | 383 | -- | Create an operation that never resumes (an exception). 384 | -- (See `handlerRet` for an example). 385 | except :: (a -> Eff e ans) -> Op a b e ans 386 | except f = Op (\m ctx x -> yield m (\ctlk -> f x)) 387 | 388 | -------------------------------------------------------------------------------- 389 | -- Efficient (and safe) Local state handler 390 | -------------------------------------------------------------------------------- 391 | -- | The type of the built-in state effect. 392 | -- (This state is generally more efficient than rolling your own and usually 393 | -- used in combination with `handlerLocal` to provide local isolated state) 394 | newtype Local a e ans = Local (IORef a) 395 | 396 | -- | Unsafe `IO` in the `Eff` monad. 397 | {-# INLINE unsafeIO #-} 398 | unsafeIO :: IO a -> Eff e a 399 | unsafeIO io = let x = unsafeInlinePrim io in seq x (Eff $ \_ -> Pure x) 400 | 401 | -- | Get the value of the local state. 402 | {-# INLINE lget #-} 403 | lget :: Local a e ans -> Op () a e ans 404 | lget (Local r) = Op (\m ctx x -> unsafeIO (seq x $ readIORef r)) 405 | 406 | -- | Set the value of the local state. 407 | {-# INLINE lput #-} 408 | lput :: Local a e ans -> Op a () e ans 409 | lput (Local r) = Op (\m ctx x -> unsafeIO (writeIORef r x)) 410 | 411 | -- | Update the value of the local state. 412 | {-# INLINE lmodify #-} 413 | lmodify :: Local a e ans -> Op (a -> a) () e ans 414 | lmodify (Local r) = Op (\m ctx f -> unsafeIO (do{ x <- readIORef r; writeIORef r $! (f x) })) 415 | 416 | -- | Get the value of the local state if it is the top handler. 417 | localGet :: Eff (Local a :* e) a 418 | localGet = perform lget () 419 | 420 | -- | Set the value of the local state if it is the top handler. 421 | localPut :: a -> Eff (Local a :* e) () 422 | localPut x = perform lput x 423 | 424 | -- | Update the value of the local state if it is the top handler. 425 | localModify :: (a -> a) -> Eff (Local a :* e) () 426 | localModify f = perform lmodify f 427 | 428 | -- A special prompt that saves and restores state per resumption 429 | mpromptIORef :: IORef a -> Eff e b -> Eff e b 430 | mpromptIORef r action 431 | = Eff $ \ctx -> case (unEff action ctx) of 432 | p@(Pure _) -> p 433 | Control m op cont 434 | -> do val <- unEff (unsafeIO (readIORef r)) ctx -- save current value on yielding 435 | let cont' x = do unsafeIO (writeIORef r val) -- restore saved value on resume 436 | mpromptIORef r (cont x) 437 | Control m op cont' 438 | 439 | -- | Create an `IORef` connected to a prompt. The value of 440 | -- the `IORef` is saved and restored through resumptions. 441 | unsafePromptIORef :: a -> (Marker h e b -> IORef a -> Eff e b) -> Eff e b 442 | unsafePromptIORef init action 443 | = freshMarker $ \m -> 444 | do r <- unsafeIO (newIORef init) 445 | mpromptIORef r (action m r) 446 | 447 | -- | Create a local state handler with an initial state of type @a@, 448 | -- with a return function to combine the final result with the final state to a value of type @b@. 449 | {-# INLINE localRet #-} 450 | localRet :: a -> (ans -> a -> b) -> Eff (Local a :* e) ans -> Eff e b 451 | localRet init ret action 452 | = unsafePromptIORef init $ \m r -> -- set a fresh prompt with marker `m` 453 | do x <- ctxMap (\ctx -> CCons m (Local r) CTId ctx) action -- and call action with the extra evidence 454 | y <- unsafeIO (readIORef r) 455 | return (ret x y) 456 | 457 | -- | Create a local state handler with an initial state of type @a@. 458 | {-# INLINE local #-} 459 | local :: a -> Eff (Local a :* e) ans -> Eff e ans 460 | local init action 461 | = localRet init const action 462 | 463 | -- | Create a new handler for @h@ which can access the /locally isolated state/ @`Local` a@. 464 | -- This is fully local to the handler @h@ only and not visible in the @action@ as 465 | -- apparent from its effect context (which does /not/ contain @`Local` a@). The 466 | -- @ret@ argument can be used to transform the final result combined with the final state. 467 | {-# INLINE handlerLocalRet #-} 468 | handlerLocalRet :: a -> (ans -> a -> b) -> (h (Local a :* e) b) -> Eff (h :* e) ans -> Eff e b 469 | handlerLocalRet init ret h action 470 | = local init $ handlerHideRetEff (\x -> do{ y <- localGet; return (ret x y)}) h action 471 | 472 | -- | Create a new handler for @h@ which can access the /locally isolated state/ @`Local` a@. 473 | -- This is fully local to the handler @h@ only and not visible in the @action@ as 474 | -- apparent from its effect context (which does /not/ contain @`Local` a@). 475 | -- 476 | -- @ 477 | -- data State a e ans = State { get :: `Op` () a e ans, put :: `Op` a () e ans } 478 | -- 479 | -- state :: a -> `Eff` (State a `:*` e) ans -> `Eff` e ans 480 | -- state init = `handlerLocal` init (State{ get = `function` (\\_ -> `perform` `lget` ()), 481 | -- put = `function` (\\x -> `perform` `lput` x) }) 482 | -- 483 | -- test = `runEff` $ 484 | -- state (41::Int) $ 485 | -- inc -- see `:?` 486 | -- @ 487 | {-# INLINE handlerLocal #-} 488 | handlerLocal :: a -> (h (Local a :* e) ans) -> Eff (h :* e) ans -> Eff e ans 489 | handlerLocal init h action 490 | = local init (handlerHide h action) 491 | -------------------------------------------------------------------------------- /src/Control/Mp/Util.hs: -------------------------------------------------------------------------------- 1 | {-| 2 | Description : Definitions for some common effects. 3 | Copyright : (c) 2021, Microsoft Research; Daan Leijen; Ningning Xie 4 | License : MIT 5 | Maintainer : xnning@hku.hk; daan@microsoft.com 6 | Stability : Experimental 7 | 8 | Some definitions for common effects. 9 | -} 10 | {-# LANGUAGE TypeOperators, FlexibleContexts, FlexibleInstances, MultiParamTypeClasses, UndecidableInstances, Rank2Types #-} 11 | module Control.Mp.Util 12 | ( 13 | -- * Reader 14 | Reader(Reader,ask) 15 | , reader 16 | -- * State 17 | , State(State,get,put) 18 | , state 19 | -- * Writer 20 | , Writer(Writer,tell) 21 | , writer 22 | -- * Exception 23 | , Except(Except,throwError) 24 | , catchError, exceptEither, exceptMaybe, exceptDefault 25 | -- * Choice 26 | , Choose(Choose,none,choose) 27 | , chooseFirst, chooseAll 28 | ) where 29 | 30 | import Control.Mp.Eff 31 | import Control.Monad 32 | import Control.Applicative 33 | 34 | ------------ 35 | -- Reader 36 | ------------ 37 | 38 | -- | A standard reader effect for values of type @a@. 39 | data Reader a e ans = Reader { ask :: !(Op () a e ans) -- ^ get the reader value of type @a@ (as @`perform` ask ()@) 40 | } 41 | 42 | -- | A handler for a `Reader` effect with a value of type @a@. 43 | {-# INLINE reader #-} 44 | reader :: a -> Eff (Reader a :* e) ans -> Eff e ans 45 | reader x 46 | = handler (Reader{ ask = value x }) 47 | 48 | {- 49 | -- does not work due to the functional dependency in MonadReader 50 | instance (Reader a :? e) => MR.MonadReader a (Eff e) where 51 | ask = perform ask () 52 | -} 53 | 54 | ------------ 55 | -- State 56 | ------------ 57 | 58 | -- | A standard state effect of type @a@. 59 | data State a e ans = State { get :: !(Op () a e ans) -- ^ Get the current state (as @`perform` get ()@) 60 | , put :: !(Op a () e ans) -- ^ Set the current state (as @`perform` put x@) 61 | } 62 | 63 | -- | A state handler that takes an initial state of type @a@. 64 | {-# INLINE state #-} 65 | state :: a -> Eff (State a :* e) ans -> Eff e ans 66 | state init 67 | = handlerLocal init (State{ get = function (\_ -> localGet), 68 | put = function (\x -> localPut x) }) 69 | 70 | 71 | {- 72 | -- does not work due to the functional dependency in MonadState 73 | instance (State a :? e) => MS.MonadState a (Eff e) where 74 | get = perform get () 75 | put x = perform put x 76 | -} 77 | 78 | ------------ 79 | -- Writer 80 | ------------ 81 | 82 | -- | A standard writer effect of type @a@ 83 | data Writer a e ans = Writer { tell :: !(Op a () e ans) -- ^ Output a value of type @a@ (as @`perform` tell msg@) 84 | } 85 | 86 | -- | A standard `Writer` handler for any monoidal type @a@. Returns the final 87 | -- result of type @ans@ and the appended @tell@ arguments. 88 | {-# INLINE writer #-} 89 | writer :: (Monoid a) => Eff (Writer a :* e) ans -> Eff e (ans,a) 90 | writer 91 | = handlerLocalRet mempty (,) $ 92 | Writer{ tell = function (\x -> do{ xs <- localGet; localPut (mappend xs x); return () }) } 93 | 94 | 95 | ------------ 96 | -- Except 97 | ------------ 98 | 99 | -- | A standard exception effect, throwing values of type @a@. 100 | data Except a e ans = Except { throwError :: !(forall b. Op a b e ans) -- ^ Throw an exception with a value of type @a@ (as @`perform` throwError x@) 101 | } 102 | 103 | -- | Handle an exception. 104 | catchError :: Eff (Except a :* e) ans -> (a -> Eff e ans) -> Eff e ans 105 | catchError action h 106 | = handler (Except{ throwError = except (\x -> h x) }) action 107 | 108 | -- | Transform an exception effect to an @Either@ type. 109 | exceptEither :: Eff (Except a :* e) ans -> Eff e (Either a ans) 110 | exceptEither 111 | = handlerRet Right (Except{ throwError = except (\x -> return (Left x) ) }) 112 | 113 | -- | Remove the exception effect using a default value in case an exception was thrown. 114 | exceptDefault :: ans -> Eff (Except a :* e) ans -> Eff e ans 115 | exceptDefault def 116 | = handler (Except{ throwError = except (\_ -> return def) }) 117 | 118 | -- | Transform an exception effect to a @Maybe@ type. 119 | exceptMaybe :: Eff (Except a :* e) ans -> Eff e (Maybe ans) 120 | exceptMaybe 121 | = handlerRet Just (Except{ throwError = except (\_ -> return Nothing) }) 122 | 123 | 124 | 125 | -------------------------------------------------------------------------------- 126 | -- Choose 127 | -------------------------------------------------------------------------------- 128 | 129 | -- | Choose implements backtracking. 130 | data Choose e ans = Choose { none :: !(forall a. Op () a e ans) -- ^ @`perform none ()` indicates no result 131 | , choose :: !(Op Int Int e ans) -- ^ @`perform` choose n` resumes up to @n@ times (returning @1@ up to @n@) 132 | } 133 | 134 | 135 | -- | Return the first result found in a computation using `choose` for backtracking. 136 | chooseFirst :: Eff (Choose :* e) ans -> Eff e (Maybe ans) 137 | chooseFirst 138 | = handlerRet Just $ 139 | Choose{ none = except (\_ -> return Nothing) 140 | , choose = operation (\hi k -> let try n = if (n > hi) 141 | then return Nothing 142 | else do x <- k n 143 | case x of 144 | Nothing -> try (n+1) 145 | _ -> return x 146 | in try 1) 147 | } 148 | 149 | -- | Return all possible results found in a computation using `choose` for backtracking 150 | chooseAll :: Eff (Choose :* e) a -> Eff e [a] 151 | chooseAll 152 | = handlerRet (\x -> [x]) $ 153 | Choose{ none = except (\_ -> return []) 154 | , choose = operation (\hi k -> let collect 0 acc = return acc 155 | collect n acc = do xs <- k n 156 | collect (n-1) $! (xs ++ acc) 157 | in collect hi []) 158 | } 159 | 160 | instance (Choose :? e) => Alternative (Eff e) where 161 | empty = perform none () 162 | m1 <|> m2 = do x <- perform choose 2 163 | if (x==1) then m1 else m2 164 | 165 | instance (Choose :? e) => MonadPlus (Eff e) where 166 | mzero = perform none () 167 | mplus m1 m2 = do x <- perform choose 2 168 | if (x==1) then m1 else m2 169 | -------------------------------------------------------------------------------- /stack.yaml: -------------------------------------------------------------------------------- 1 | # This file was automatically generated by 'stack init' 2 | # 3 | # Some commonly used options have been documented as comments in this file. 4 | # For advanced use and comprehensive documentation of the format, please see: 5 | # https://docs.haskellstack.org/en/stable/yaml_configuration/ 6 | 7 | # Resolver to choose a 'specific' stackage snapshot or a compiler version. 8 | # A snapshot resolver dictates the compiler version and the set of packages 9 | # to be used for project dependencies. For example: 10 | # 11 | # resolver: lts-3.5 12 | # resolver: nightly-2015-09-21 13 | # resolver: ghc-7.10.2 14 | # 15 | # The location of a snapshot can be provided as a file or url. Stack assumes 16 | # a snapshot provided as a file might change, whereas a url resource does not. 17 | # 18 | # resolver: ./custom-snapshot.yaml 19 | # resolver: https://example.com/snapshots/2018-01-01.yaml 20 | resolver: 21 | url: https://raw.githubusercontent.com/commercialhaskell/stackage-snapshots/master/lts/17/5.yaml 22 | 23 | # User packages to be built. 24 | # Various formats can be used as shown in the example below. 25 | # 26 | # packages: 27 | # - some-directory 28 | # - https://example.com/foo/bar/baz-0.0.2.tar.gz 29 | # subdirs: 30 | # - auto-update 31 | # - wai 32 | packages: 33 | - . 34 | # Dependency packages to be pulled from upstream that are not in the resolver. 35 | # These entries can reference officially published versions as well as 36 | # forks / in-progress versions pinned to a git hash. For example: 37 | # 38 | # extra-deps: 39 | # - acme-missiles-0.3 40 | # - git: https://github.com/commercialhaskell/stack.git 41 | # commit: e7b331f14bcffb8367cd58fbfc8b40ec7642100a 42 | # 43 | # extra-deps: [] 44 | 45 | # Override default flag values for local packages and extra-deps 46 | # flags: {} 47 | 48 | # Extra package databases containing global packages 49 | # extra-package-dbs: [] 50 | 51 | # Control whether we use the GHC we find on the path 52 | # system-ghc: true 53 | # 54 | # Require a specific version of stack, using version ranges 55 | # require-stack-version: -any # Default 56 | # require-stack-version: ">=2.5" 57 | # 58 | # Override the architecture used by stack, especially useful on Windows 59 | # arch: i386 60 | # arch: x86_64 61 | # 62 | # Extra directories used by stack for building 63 | # extra-include-dirs: [/path/to/dir] 64 | # extra-lib-dirs: [/path/to/dir] 65 | # 66 | # Allow a newer minor version of GHC than the snapshot specifies 67 | # compiler-check: newer-minor 68 | --------------------------------------------------------------------------------