simple-effects 0.1.0.1 → 0.1.0.2

raw patch · 6 files changed

+220/−165 lines, 6 files

Files

• bench/Bench.hs +23/−23
• simple-effects.cabal +8/−7
• src/Control/Effects.hs +50/−48
• src/Control/Effects/Reader.hs +22/−22
• src/Control/Effects/State.hs +65/−65
• src/Control/Effects1.hs +52/−0

@@ -1,23 +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)
-        ]
+{-# 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)+        ]

@@ -1,19 +1,20 @@ name:                simple-effects-version:             0.1.0.1-synopsis:            Simple project template from stack+version:             0.1.0.2+synopsis:            A simple effect system that integrates with MTL description:         Please see README.md-homepage:            https://github.com/githubuser/simple-effects#readme+homepage:            https://gitlab.com/LukaHorvat/simple-effects license:             BSD3 license-file:        LICENSE-author:              Author name here-maintainer:          example@example.com-copyright:           2016 Author name here-category:            Web+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   hs-source-dirs:      src

@@ -1,48 +1,50 @@-{-# 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
+{-# 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+    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

@@ -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)

@@ -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) = ()
-
-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)
+{-# 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)

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