simple-effects 0.3.0.1 → 0.3.0.2

raw patch · 8 files changed

+306/−238 lines, 8 filessetup-changed

Files

LICENSE +29/−29
Setup.hs +2/−2
bench/Bench.hs +24/−24
simple-effects.cabal +45/−44
src/Control/Effects.hs +52/−52
src/Control/Effects/Reader.hs +22/−22
src/Control/Effects/Signal.hs +67/−0
src/Control/Effects/State.hs +65/−65

LICENSE view

@@ -1,30 +1,30 @@-Copyright Author name here (c) 2016--All rights reserved.--Redistribution and use in source and binary forms, with or without-modification, are permitted provided that the following conditions are met:--    * Redistributions of source code must retain the above copyright-      notice, this list of conditions and the following disclaimer.--    * Redistributions in binary form must reproduce the above-      copyright notice, this list of conditions and the following-      disclaimer in the documentation and/or other materials provided-      with the distribution.--    * Neither the name of Author name here nor the names of other-      contributors may be used to endorse or promote products derived-      from this software without specific prior written permission.--THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS-"AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT-LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR-A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT-OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL,-SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT-LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE,-DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY-THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT-(INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE+Copyright Author name here (c) 2016
+
+All rights reserved.
+
+Redistribution and use in source and binary forms, with or without
+modification, are permitted provided that the following conditions are met:
+
+    * Redistributions of source code must retain the above copyright
+      notice, this list of conditions and the following disclaimer.
+
+    * Redistributions in binary form must reproduce the above
+      copyright notice, this list of conditions and the following
+      disclaimer in the documentation and/or other materials provided
+      with the distribution.
+
+    * Neither the name of Author name here nor the names of other
+      contributors may be used to endorse or promote products derived
+      from this software without specific prior written permission.
+
+THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS
+"AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT
+LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR
+A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT
+OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL,
+SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT
+LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE,
+DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY
+THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT
+(INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE
 OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.

Setup.hs view

@@ -1,2 +1,2 @@-import Distribution.Simple-main = defaultMain+import Distribution.Simple
+main = defaultMain

bench/Bench.hs view

@@ -1,24 +1,24 @@-{-# LANGUAGE FlexibleContexts, TypeApplications #-}-import Interlude--import GHC.IO.Encoding (setLocaleEncoding, utf16)-import Control.Effects-import Control.Effects.State hiding (mtlSimple, effectsSimple)--import Criterion.Main--mtlSimple :: MonadState Int m => m ()-mtlSimple = replicateM_ 1000000 mtlSimple'-    where mtlSimple' = modify' (+ 1)--effectsSimple :: (MonadEffect (GetState Int) m, MonadEffect (SetState Int) m) => m ()-effectsSimple = replicateM_ 1000000 effectsSimple'-    where effectsSimple' = modifyState (+ (1 :: Int))--main :: IO ()-main =-    defaultMain-        [ bench "MTL state" $ nfIO (execStateT mtlSimple 0)-        , bench "Effects state" $ nfIO effState-        ]-    where effState = handleStateIO @_ @Int @Int 0 (effectsSimple >> getState)+{-# LANGUAGE FlexibleContexts, TypeApplications #-}
+import Interlude
+
+import GHC.IO.Encoding (setLocaleEncoding, utf16)
+import Control.Effects
+import Control.Effects.State hiding (mtlSimple, effectsSimple)
+
+import Criterion.Main
+
+mtlSimple :: MonadState Int m => m ()
+mtlSimple = replicateM_ 1000000 mtlSimple'
+    where mtlSimple' = modify' (+ 1)
+
+effectsSimple :: (MonadEffect (GetState Int) m, MonadEffect (SetState Int) m) => m ()
+effectsSimple = replicateM_ 1000000 effectsSimple'
+    where effectsSimple' = modifyState (+ (1 :: Int))
+
+main :: IO ()
+main =
+    defaultMain
+        [ bench "MTL state" $ nfIO (execStateT mtlSimple 0)
+        , bench "Effects state" $ nfIO effState
+        ]
+    where effState = handleStateIO @_ @Int @Int 0 (effectsSimple >> getState)

simple-effects.cabal view

@@ -1,44 +1,45 @@-name:                simple-effects-version:             0.3.0.1    -synopsis:            A simple effect system that integrates with MTL-description:         Please see README.md-homepage:            https://gitlab.com/LukaHorvat/simple-effects-license:             BSD3-license-file:        LICENSE-author:              Luka Horvat-maintainer:          luka.horvat9@gmail.com-copyright:           2016 Luka Horvat-category:            Control-build-type:          Simple-cabal-version:       >=1.10--library-  exposed-modules:     Control.Effects-                     , Control.Effects1-                     , Control.Effects.State-                     , Control.Effects.Reader-                     , Control.Effects.List-  hs-source-dirs:      src-  default-language:    Haskell2010-  build-depends:       base >= 4.7 && < 5-                     , transformers-                     , mtl-                     , interlude-l >= 0.1.0.6-                     , monad-control == 1.0.*-                     , transformers-base == 0.4.*-                     , list-t-                     , lens-  default-extensions:  NoImplicitPrelude--benchmark bench-effects-  type:                exitcode-stdio-1.0-  hs-source-dirs:      bench-  main-is:             Bench.hs-  build-depends:       base-                     , criterion-                     , mtl-                     , transformers-                     , interlude-l-                     , lens-                     , simple-effects-  default-language:    Haskell2010+name:                simple-effects
+version:             0.3.0.2
+synopsis:            A simple effect system that integrates with MTL
+description:         Please see README.md
+homepage:            https://gitlab.com/LukaHorvat/simple-effects
+license:             BSD3
+license-file:        LICENSE
+author:              Luka Horvat
+maintainer:          luka.horvat9@gmail.com
+copyright:           2016 Luka Horvat
+category:            Control
+build-type:          Simple
+cabal-version:       >=1.10
+
+library
+  exposed-modules:     Control.Effects
+                     , Control.Effects1
+                     , Control.Effects.State
+                     , Control.Effects.Reader
+                     , Control.Effects.List
+                     , Control.Effects.Signal
+  hs-source-dirs:      src
+  default-language:    Haskell2010
+  build-depends:       base >= 4.7 && < 5
+                     , transformers
+                     , mtl
+                     , interlude-l >= 0.1.0.6
+                     , monad-control == 1.0.*
+                     , transformers-base == 0.4.*
+                     , list-t
+                     , lens
+  default-extensions:  NoImplicitPrelude
+
+benchmark bench-effects
+  type:                exitcode-stdio-1.0
+  hs-source-dirs:      bench
+  main-is:             Bench.hs
+  build-depends:       base
+                     , criterion
+                     , mtl
+                     , transformers
+                     , interlude-l
+                     , lens
+                     , simple-effects
+  default-language:    Haskell2010

src/Control/Effects.hs view

@@ -1,52 +1,52 @@-{-# LANGUAGE TypeFamilies, MultiParamTypeClasses, FlexibleInstances, DeriveFunctor-           , GeneralizedNewtypeDeriving, UndecidableInstances, StandaloneDeriving-           , IncoherentInstances #-}-module Control.Effects (module Control.Effects, module Control.Effects1) where--import Interlude--import Control.Monad.Reader-import Control.Monad.Trans.Control-import Control.Monad.Base--import Control.Effects1--type family EffectMsg eff :: *-type family EffectRes eff :: *--class Monad m => MonadEffect eff m where-    -- | Use the effect described by 'eff'.-    effect :: proxy eff -> EffectMsg eff -> m (EffectRes eff)---- | The 'EffectHandler' is rally just a 'ReaderT' carrying around the function that knows how to---   handle the effect.-newtype EffectHandler eff m a = EffectHandler-    { unpackEffectHandler :: ReaderT (EffectMsg eff -> m (EffectRes eff)) m a }-    deriving (Functor, Applicative, Monad, MonadState s, MonadIO, MonadCatch, MonadThrow, MonadRandom)--instance MonadTrans (EffectHandler eff) where-    lift = EffectHandler . lift--instance MonadReader s m => MonadReader s (EffectHandler eff m) where-    ask = EffectHandler (lift ask)-    local f (EffectHandler rdr) = EffectHandler (ReaderT $ local f . runReaderT rdr)--deriving instance MonadBase IO m => MonadBase IO (EffectHandler eff m)--instance MonadBaseControl IO m => MonadBaseControl IO (EffectHandler eff m) where-    type StM (EffectHandler eff m) a = StM (ReaderT (EffectMsg eff -> m (EffectRes eff)) m) a-    liftBaseWith f = EffectHandler $ liftBaseWith $ \q -> f (q . unpackEffectHandler)-    restoreM = EffectHandler . restoreM--instance {-# OVERLAPPABLE #-} (MonadEffect eff m, MonadTrans t, Monad (t m))-         => MonadEffect eff (t m) where-    {-# INLINE effect #-}-    effect p msg = lift (effect p msg)--instance Monad m => MonadEffect eff (EffectHandler eff m) where-    {-# INLINE effect #-}-    effect _ msg = EffectHandler (ReaderT ($ msg))---- | Handle the effect described by 'eff'.-handleEffect :: Monad m => (EffectMsg eff -> m (EffectRes eff)) -> EffectHandler eff m a -> m a-handleEffect f eh = runReaderT (unpackEffectHandler eh) f+{-# LANGUAGE TypeFamilies, MultiParamTypeClasses, FlexibleInstances, DeriveFunctor
+           , GeneralizedNewtypeDeriving, UndecidableInstances, StandaloneDeriving
+           , IncoherentInstances #-}
+module Control.Effects (module Control.Effects, module Control.Effects1) where
+
+import Interlude
+
+import Control.Monad.Reader
+import Control.Monad.Trans.Control
+import Control.Monad.Base
+
+import Control.Effects1
+
+type family EffectMsg eff :: *
+type family EffectRes eff :: *
+
+class Monad m => MonadEffect eff m where
+    -- | Use the effect described by 'eff'.
+    effect :: proxy eff -> EffectMsg eff -> m (EffectRes eff)
+
+-- | The 'EffectHandler' is rally just a 'ReaderT' carrying around the function that knows how to
+--   handle the effect.
+newtype EffectHandler eff m a = EffectHandler
+    { unpackEffectHandler :: ReaderT (EffectMsg eff -> m (EffectRes eff)) m a }
+    deriving (Functor, Applicative, Monad, MonadState s, MonadIO, MonadCatch, MonadThrow, MonadRandom)
+
+instance MonadTrans (EffectHandler eff) where
+    lift = EffectHandler . lift
+
+instance MonadReader s m => MonadReader s (EffectHandler eff m) where
+    ask = EffectHandler (lift ask)
+    local f (EffectHandler rdr) = EffectHandler (ReaderT $ local f . runReaderT rdr)
+
+deriving instance MonadBase IO m => MonadBase IO (EffectHandler eff m)
+
+instance MonadBaseControl IO m => MonadBaseControl IO (EffectHandler eff m) where
+    type StM (EffectHandler eff m) a = StM (ReaderT (EffectMsg eff -> m (EffectRes eff)) m) a
+    liftBaseWith f = EffectHandler $ liftBaseWith $ \q -> f (q . unpackEffectHandler)
+    restoreM = EffectHandler . restoreM
+
+instance {-# OVERLAPPABLE #-} (MonadEffect eff m, MonadTrans t, Monad (t m))
+         => MonadEffect eff (t m) where
+    {-# INLINE effect #-}
+    effect p msg = lift (effect p msg)
+
+instance Monad m => MonadEffect eff (EffectHandler eff m) where
+    {-# INLINE effect #-}
+    effect _ msg = EffectHandler (ReaderT ($ msg))
+
+-- | Handle the effect described by 'eff'.
+handleEffect :: Monad m => (EffectMsg eff -> m (EffectRes eff)) -> EffectHandler eff m a -> m a
+handleEffect f eh = runReaderT (unpackEffectHandler eh) f

src/Control/Effects/Reader.hs view

@@ -1,22 +1,22 @@-{-# LANGUAGE ScopedTypeVariables, TypeFamilies, FlexibleContexts #-}-module Control.Effects.Reader (module Control.Effects.Reader, module Control.Effects) where--import Interlude--import Control.Lens--import Control.Effects--data ReadEnv e--type instance EffectMsg (ReadEnv e) = ()-type instance EffectRes (ReadEnv e) = e--readEnv :: forall m e. MonadEffect (ReadEnv e) m => m e-readEnv = effect (Proxy :: Proxy (ReadEnv e)) ()--handleReadEnv :: Monad m => m e -> EffectHandler (ReadEnv e) m a -> m a-handleReadEnv = handleEffect . const--handleSubreader :: MonadEffect (ReadEnv e) m => (e -> e') -> EffectHandler (ReadEnv e') m a -> m a-handleSubreader f = handleReadEnv (f <$> readEnv)+{-# LANGUAGE ScopedTypeVariables, TypeFamilies, FlexibleContexts #-}
+module Control.Effects.Reader (module Control.Effects.Reader, module Control.Effects) where
+
+import Interlude
+
+import Control.Lens
+
+import Control.Effects
+
+data ReadEnv e
+
+type instance EffectMsg (ReadEnv e) = ()
+type instance EffectRes (ReadEnv e) = e
+
+readEnv :: forall m e. MonadEffect (ReadEnv e) m => m e
+readEnv = effect (Proxy :: Proxy (ReadEnv e)) ()
+
+handleReadEnv :: Monad m => m e -> EffectHandler (ReadEnv e) m a -> m a
+handleReadEnv = handleEffect . const
+
+handleSubreader :: MonadEffect (ReadEnv e) m => (e -> e') -> EffectHandler (ReadEnv e') m a -> m a
+handleSubreader f = handleReadEnv (f <$> readEnv)

+ src/Control/Effects/Signal.hs view

@@ -0,0 +1,67 @@+{-# LANGUAGE TypeFamilies, ScopedTypeVariables, FlexibleContexts, Rank2Types, ConstraintKinds #-}
+{-# LANGUAGE DeriveAnyClass, OverloadedStrings, MultiParamTypeClasses, FunctionalDependencies #-}
+{-# LANGUAGE FlexibleInstances, UndecidableInstances #-}
+module Control.Effects.Signal
+    ( MonadEffectSignal(..), ResumeOrBreak(..), throwSignal, handleSignal, handleAsException
+    , module Control.Effects ) where
+
+import Interlude
+import Prelude (Show(..))
+
+import Control.Effects
+
+data Signal a b
+type instance EffectMsg (Signal a b) = a
+type instance EffectRes (Signal a b) = b
+
+-- | This class allows you to "throw" a signal. For the most part signals are the same as checked
+--   exceptions. The difference here is that the handler has the option to provide the value that
+--   will be the result _of calling the signal function_. This effectibvely allows you to have
+--   recoverable exceptions at the call site, instead of just at the handling site.
+--
+--   This class can be considered an alias for @MonadEffect (Signal a b)@ so your code isn't
+--   required to provide any instances.
+class MonadEffect (Signal a b) m => MonadEffectSignal a b m | m a -> b where
+    -- | There are no restrictions on the type of values that can be thrown or returned.
+    signal :: a -> m b
+    signal = effect (Proxy :: Proxy (Signal a b))
+
+instance Monad m => MonadEffectSignal a b (EffectHandler (Signal a b) m)
+instance {-# OVERLAPPABLE #-} (MonadEffectSignal a b m, MonadTrans t, Monad (t m))
+         => MonadEffectSignal a b (t m)
+
+-- | The handle function will return a value of this type.
+data ResumeOrBreak b c = Resume b -- ^ Give a value to the caller of @signal@ and keep going.
+                       | Break c -- ^ Continue the execution after the handler. The handler will
+                                 --   return this value
+
+data NoResume a = NoResume a deriving (Eq, Ord)
+instance Show (NoResume a) where
+    show = const "NoResume"
+instance Typeable a => Exception (NoResume a)
+
+-- | Throw a signal with no possible recovery. The handler is forced to only return the @Break@
+--   constructor because it cannot construct a @Void@ value.
+--
+--   If this function is used along with @handleAsException@, this module behaves like regular
+--   checked exceptions.
+throwSignal :: MonadEffectSignal a Void m => a -> m b
+throwSignal = fmap absurd . signal
+
+-- | Handle signals of a computation. The handler function has the option to provide a value
+--   to the caller of @signal@ and continue execution there, or do what regular exception handlers
+--   do and continue execution after the handler.
+handleSignal :: (MonadCatch m, Typeable c)
+             => (a -> m (ResumeOrBreak b c)) -> EffectHandler (Signal a b) m c -> m c
+handleSignal f a =
+    handle (\(NoResume c) -> return c) $ handleEffect (\s -> do
+        rb <- f s
+        case rb of
+            Resume b -> return b
+            Break c -> throwM (NoResume c)) a
+
+-- | This handler can only behave like a regular exception handler. If used along with @throwSignal@
+--   this module behaves like regular checked exceptions.
+handleAsException :: (MonadCatch m, Typeable c)
+                => (a -> m c) -> EffectHandler (Signal a b) m c -> m c
+handleAsException f = handleSignal (fmap Break . f)

src/Control/Effects/State.hs view

@@ -1,65 +1,65 @@-{-# LANGUAGE TypeFamilies, ScopedTypeVariables, FlexibleContexts, Rank2Types, ConstraintKinds #-}-module Control.Effects.State (module Control.Effects.State, module Control.Effects) where--import Interlude--import Data.IORef-import Control.Lens--import Control.Effects--data GetState s-data SetState s--type instance EffectMsg (GetState s) = ()-type instance EffectRes (GetState s) = s--type instance EffectMsg (SetState s) = s-type instance EffectRes (SetState s) = ()--type MonadEffectState s m = (MonadEffect (GetState s) m, MonadEffect (SetState s) m)-type EffectHandlerState s m = EffectHandler (GetState s) (EffectHandler (SetState s) m)--{-# INLINE getState #-}-getState :: forall s m. MonadEffect (GetState s) m => m s-getState = effect (Proxy :: Proxy (GetState s)) ()--{-# INLINE setState #-}-setState :: forall s m. MonadEffect (SetState s) m => s -> m ()-setState = effect (Proxy :: Proxy (SetState s))--{-# INLINE modifyState #-}-modifyState :: forall s m. MonadEffectState s m => (s -> s) -> m ()-modifyState f = setState . f =<< getState--{-# INLINE handleGetState #-}-handleGetState :: Monad m => m s -> EffectHandler (GetState s) m a -> m a-handleGetState = handleEffect . const--{-# INLINE handleSetState #-}-handleSetState :: Monad m => (s -> m ()) -> EffectHandler (SetState s) m a -> m a-handleSetState = handleEffect--{-# INLINE handleState #-}-handleState :: Monad m => m s -> (s -> m ()) -> EffectHandlerState s m a -> m a-handleState getter setter = handleSetState setter . handleGetState (lift getter)--handleStateIO :: MonadIO m => s -> EffectHandlerState s m a -> m a-handleStateIO initial m = do-    ref <- liftIO (newIORef initial)-    m & handleState (liftIO (readIORef  ref)) (liftIO . writeIORef ref)--{-# INLINE handleStateT #-}-handleStateT :: Monad m => s -> EffectHandlerState s (StateT s m) a -> m a-handleStateT initial m = evalStateT (handleSetState put $ handleGetState get m) initial--handleSubstate :: MonadEffectState s m => Lens' s t -> t -> EffectHandlerState t m a -> m a-handleSubstate lensST initial m = do-    oldState <- getState-    setState (set lensST initial oldState)-    res <- m & handleGetState (view lensST <$> getState)-             & handleSetState (\s -> do-                 oldState <- getState-                 setState (oldState & lensST .~ s))-    setState oldState-    return res+{-# LANGUAGE TypeFamilies, ScopedTypeVariables, FlexibleContexts, Rank2Types, ConstraintKinds #-}
+module Control.Effects.State (module Control.Effects.State, module Control.Effects) where
+
+import Interlude
+
+import Data.IORef
+import Control.Lens
+
+import Control.Effects
+
+data GetState s
+data SetState s
+
+type instance EffectMsg (GetState s) = ()
+type instance EffectRes (GetState s) = s
+
+type instance EffectMsg (SetState s) = s
+type instance EffectRes (SetState s) = ()
+
+type MonadEffectState s m = (MonadEffect (GetState s) m, MonadEffect (SetState s) m)
+type EffectHandlerState s m = EffectHandler (GetState s) (EffectHandler (SetState s) m)
+
+{-# INLINE getState #-}
+getState :: forall s m. MonadEffect (GetState s) m => m s
+getState = effect (Proxy :: Proxy (GetState s)) ()
+
+{-# INLINE setState #-}
+setState :: forall s m. MonadEffect (SetState s) m => s -> m ()
+setState = effect (Proxy :: Proxy (SetState s))
+
+{-# INLINE modifyState #-}
+modifyState :: forall s m. MonadEffectState s m => (s -> s) -> m ()
+modifyState f = setState . f =<< getState
+
+{-# INLINE handleGetState #-}
+handleGetState :: Monad m => m s -> EffectHandler (GetState s) m a -> m a
+handleGetState = handleEffect . const
+
+{-# INLINE handleSetState #-}
+handleSetState :: Monad m => (s -> m ()) -> EffectHandler (SetState s) m a -> m a
+handleSetState = handleEffect
+
+{-# INLINE handleState #-}
+handleState :: Monad m => m s -> (s -> m ()) -> EffectHandlerState s m a -> m a
+handleState getter setter = handleSetState setter . handleGetState (lift getter)
+
+handleStateIO :: MonadIO m => s -> EffectHandlerState s m a -> m a
+handleStateIO initial m = do
+    ref <- liftIO (newIORef initial)
+    m & handleState (liftIO (readIORef  ref)) (liftIO . writeIORef ref)
+
+{-# INLINE handleStateT #-}
+handleStateT :: Monad m => s -> EffectHandlerState s (StateT s m) a -> m a
+handleStateT initial m = evalStateT (handleSetState put $ handleGetState get m) initial
+
+handleSubstate :: MonadEffectState s m => Lens' s t -> t -> EffectHandlerState t m a -> m a
+handleSubstate lensST initial m = do
+    oldState <- getState
+    setState (set lensST initial oldState)
+    res <- m & handleGetState (view lensST <$> getState)
+             & handleSetState (\s -> do
+                 oldState <- getState
+                 setState (oldState & lensST .~ s))
+    setState oldState
+    return res