simple-effects (empty) → 0.1.0.1

raw patch · 7 files changed

+230/−0 lines, 7 filesdep +basedep +criteriondep +interlude-lsetup-changed

Dependencies added: base, criterion, interlude-l, lens, monad-control, mtl, simple-effects, transformers, transformers-base

Files

LICENSE +30/−0
Setup.hs +2/−0
bench/Bench.hs +23/−0
simple-effects.cabal +40/−0
src/Control/Effects.hs +48/−0
src/Control/Effects/Reader.hs +22/−0
src/Control/Effects/State.hs +65/−0

+ LICENSE view

@@ -0,0 +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+OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.

+ Setup.hs view

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

+ bench/Bench.hs view

@@ -0,0 +1,23 @@+{-# LANGUAGE FlexibleContexts #-}
+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' = setState . (+ (1 :: Int)) =<< getState
+
+main :: IO ()
+main =
+    defaultMain
+        [ bench "MTL state" $ nfIO (execStateT mtlSimple 0)
+        , bench "Effects state" $ nfIO (handleStateIO (0 :: Int) (effectsSimple >> getState) :: IO Int)
+        ]

+ simple-effects.cabal view

@@ -0,0 +1,40 @@+name:                simple-effects+version:             0.1.0.1+synopsis:            Simple project template from stack+description:         Please see README.md+homepage:            https://github.com/githubuser/simple-effects#readme+license:             BSD3+license-file:        LICENSE+author:              Author name here+maintainer:          example@example.com+copyright:           2016 Author name here+category:            Web+build-type:          Simple+cabal-version:       >=1.10++library+  exposed-modules:     Control.Effects+                     , Control.Effects.State+                     , Control.Effects.Reader+  hs-source-dirs:      src+  default-language:    Haskell2010+  build-depends:       base >= 4.7 && < 5+                     , transformers+                     , mtl+                     , interlude-l+                     , monad-control == 1.0.*+                     , transformers-base == 0.4.*+                     , lens++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

@@ -0,0 +1,48 @@+{-# LANGUAGE TypeFamilies, MultiParamTypeClasses, FlexibleInstances, DeriveFunctor
+           , GeneralizedNewtypeDeriving, UndecidableInstances, StandaloneDeriving
+           , IncoherentInstances #-}
+module Control.Effects where
+
+import Interlude
+
+import Control.Monad.Reader
+import Control.Monad.Trans.Control
+import Control.Monad.Base
+
+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
+    effect p msg = lift (effect p msg)
+
+instance Monad m => MonadEffect eff (EffectHandler eff m) where
+    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

@@ -0,0 +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)

+ src/Control/Effects/State.hs view

@@ -0,0 +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) = ()
+
+getState :: forall m s. MonadEffect (GetState s) m => m s
+getState = effect (Proxy :: Proxy (GetState s)) ()
+
+setState :: forall m s. MonadEffect (SetState s) m => s -> m ()
+setState = effect (Proxy :: Proxy (SetState s))
+
+modifyState :: forall m s. (MonadEffect (GetState s) m, MonadEffect (SetState s) m) => (s -> s) -> m ()
+modifyState f = setState . f =<< getState
+
+handleGetState :: Monad m => m s -> EffectHandler (GetState s) m a -> m a
+handleGetState = handleEffect . const
+
+handleSetState :: Monad m => (s -> m ()) -> EffectHandler (SetState s) m a -> m a
+handleSetState = handleEffect
+
+handleStateIO :: MonadIO m => s
+                           -> EffectHandler (GetState s) (EffectHandler (SetState s) m) a
+                           -> m a
+handleStateIO initial m = do
+    ref <- liftIO (newIORef initial)
+    m & handleGetState (liftIO  (readIORef  ref))
+      & handleSetState (liftIO . writeIORef ref)
+
+handleState :: Monad m => s
+                       -> EffectHandler (GetState s)
+                         (EffectHandler (SetState s) 
+                         (StateT s m)) a
+                       -> m a
+handleState initial m = evalStateT (handleSetState put $ handleGetState get m) initial
+
+handleSubstate :: forall s t m a. (MonadEffect (GetState s) m, MonadEffect (SetState s) m)
+               => Lens' s t
+               -> t
+               -> EffectHandler (GetState t) (EffectHandler (SetState 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
+
+type MonadEffectState s m = (MonadEffect (GetState s) m, MonadEffect (SetState s) m)