packages feed

effectful (empty) → 0.0.0.0

raw patch · 22 files changed

+1754/−0 lines, 22 filesdep +basedep +containersdep +effectful

Dependencies added: base, containers, effectful, exceptions, freer-simple, fused-effects, ghc-prim, lifted-async, lifted-base, monad-control, mtl, polysemy, primitive, resourcet, tasty, tasty-bench, tasty-hunit, transformers, transformers-base, unliftio, unliftio-core

Files

+ CHANGELOG.md view
@@ -0,0 +1,2 @@+# effectful-0.0.0.0 (2021-06-13)+* Initial alpha release.
+ LICENSE view
@@ -0,0 +1,30 @@+Copyright (c) 2021, Andrzej Rybczak++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 Andrzej Rybczak 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.
+ bench/Countdown.hs view
@@ -0,0 +1,276 @@+{-# LANGUAGE CPP #-}+module Countdown where++import Data.Functor.Identity++-- eff+#ifdef VERSION_eff+import qualified Control.Effect as L+#endif++-- effectful+import qualified Effectful as E+import qualified Effectful.Reader as E+import qualified Effectful.State as E+import qualified Effectful.State.MVar as ME+import qualified Effectful.State.Dynamic as DE++-- freer-simple+#ifdef VERSION_freer_simple+import qualified Control.Monad.Freer as FS+import qualified Control.Monad.Freer.Reader as FS+import qualified Control.Monad.Freer.State as FS+#endif++-- fused-effects+#ifdef VERSION_fused_effects+import qualified Control.Algebra as FE+import qualified Control.Carrier.Reader as FE+import qualified Control.Carrier.State.Strict as FE+#endif++-- mtl+import qualified Control.Monad.Reader as M+import qualified Control.Monad.State as M++-- polysemy+#ifdef VERSION_polysemy+import qualified Polysemy as P+import qualified Polysemy.Reader as P+import qualified Polysemy.State as P+#endif++----------------------------------------+-- reference++countdownRef :: Integer -> (Integer, Integer)+countdownRef n = if n <= 0 then (n, n) else countdownRef $ n - 1+{-# NOINLINE countdownRef #-}++----------------------------------------+-- mtl++programMtl :: M.MonadState Integer m => m Integer+programMtl = do+  n <- M.get @Integer+  if n <= 0+    then pure n+    else do+      M.put (n - 1)+      programMtl+{-# NOINLINE programMtl #-}++countdownMtl :: Integer -> (Integer, Integer)+countdownMtl n = flip M.runState n $ programMtl++countdownMtlDeep :: Integer -> (Integer, Integer)+countdownMtlDeep n = runIdentity+  . runR . runR . runR . runR . runR . runR . runR . runR . runR . runR+  . flip M.runStateT n+  . runR . runR . runR . runR . runR . runR . runR . runR . runR . runR+  $ programMtl+  where+    runR = flip M.runReaderT ()++----------------------------------------+-- effectful (pure)++programEffectfulStatic :: E.State Integer E.:> es => E.Eff es Integer+programEffectfulStatic = do+  n <- E.get @Integer+  if n <= 0+    then pure n+    else do+      E.put (n - 1)+      programEffectfulStatic+{-# NOINLINE programEffectfulStatic #-}++countdownEffectfulStatic :: Integer -> IO (Integer, Integer)+countdownEffectfulStatic n = E.runEff . E.runState n $ programEffectfulStatic++countdownEffectfulStaticDeep :: Integer -> IO (Integer, Integer)+countdownEffectfulStaticDeep n = E.runEff+  . runR . runR . runR . runR . runR . runR . runR . runR . runR . runR+  . E.runState n+  . runR . runR . runR . runR . runR . runR . runR . runR . runR . runR+  $ programEffectfulStatic+  where+    runR = E.runReader ()++----------------------------------------+-- effectful (mvar)++programEffectfulMVar :: ME.State Integer E.:> es => E.Eff es Integer+programEffectfulMVar = do+  n <- ME.get @Integer+  if n <= 0+    then pure n+    else do+      ME.put (n - 1)+      programEffectfulMVar+{-# NOINLINE programEffectfulMVar #-}++countdownEffectfulMVar :: Integer -> IO (Integer, Integer)+countdownEffectfulMVar n = E.runEff . ME.runState n $ programEffectfulMVar++countdownEffectfulMVarDeep :: Integer -> IO (Integer, Integer)+countdownEffectfulMVarDeep n = E.runEff+  . runR . runR . runR . runR . runR . runR . runR . runR . runR . runR+  . ME.runState n+  . runR . runR . runR . runR . runR . runR . runR . runR . runR . runR+  $ programEffectfulMVar+  where+    runR = E.runReader ()++----------------------------------------+-- effectful (dynamic)++programEffectfulDynamic :: DE.State Integer E.:> es => E.Eff es Integer+programEffectfulDynamic = do+  n <- DE.get @Integer+  if n <= 0+    then pure n+    else do+      DE.put (n - 1)+      programEffectfulDynamic+{-# NOINLINE programEffectfulDynamic #-}++countdownEffectfulDynPure :: Integer -> IO (Integer, Integer)+countdownEffectfulDynPure n = E.runEff . DE.runState n $ programEffectfulDynamic++countdownEffectfulDynMVar :: Integer -> IO (Integer, Integer)+countdownEffectfulDynMVar n = E.runEff . DE.runStateMVar n $ programEffectfulDynamic++countdownEffectfulDynPureDeep :: Integer -> IO (Integer, Integer)+countdownEffectfulDynPureDeep n = E.runEff+  . runR . runR . runR . runR . runR . runR . runR . runR . runR . runR+  . DE.runState n+  . runR . runR . runR . runR . runR . runR . runR . runR . runR . runR+  $ programEffectfulDynamic+  where+    runR = E.runReader ()++countdownEffectfulDynMVarDeep :: Integer -> IO (Integer, Integer)+countdownEffectfulDynMVarDeep n = E.runEff+  . runR . runR . runR . runR . runR . runR . runR . runR . runR . runR+  . DE.runStateMVar n+  . runR . runR . runR . runR . runR . runR . runR . runR . runR . runR+  $ programEffectfulDynamic+  where+    runR = E.runReader ()++----------------------------------------+-- fused-effects++#ifdef VERSION_fused_effects++programFusedEffects :: FE.Has (FE.State Integer) sig m => m Integer+programFusedEffects = do+  n <- FE.get @Integer+  if n <= 0+    then pure n+    else do+      FE.put (n - 1)+      programFusedEffects+{-# NOINLINE programFusedEffects #-}++countdownFusedEffects :: Integer -> (Integer, Integer)+countdownFusedEffects n = FE.run . FE.runState n $ programFusedEffects++countdownFusedEffectsDeep :: Integer -> (Integer, Integer)+countdownFusedEffectsDeep n = FE.run+  . runR . runR . runR . runR . runR . runR . runR . runR . runR . runR+  . FE.runState n+  . runR . runR . runR . runR . runR . runR . runR . runR . runR . runR+  $ programFusedEffects+  where+    runR = FE.runReader ()++#endif++----------------------------------------+-- polysemy++#ifdef VERSION_polysemy++programPolysemy :: P.Member (P.State Integer) r => P.Sem r Integer+programPolysemy = do+  n <- P.get @Integer+  if n <= 0+    then pure n+    else do+      P.put (n - 1)+      programPolysemy+{-# NOINLINE programPolysemy #-}++countdownPolysemy :: Integer -> (Integer, Integer)+countdownPolysemy n = P.run . P.runState n $ programPolysemy++countdownPolysemyDeep :: Integer -> (Integer, Integer)+countdownPolysemyDeep n = P.run+  . runR . runR . runR . runR . runR . runR . runR . runR . runR . runR+  . P.runState n+  . runR . runR . runR . runR . runR . runR . runR . runR . runR . runR+  $ programPolysemy+  where+    runR = P.runReader ()++#endif++----------------------------------------+-- eff++#ifdef VERSION_eff++programEff :: L.State Integer L.:< es => L.Eff es Integer+programEff = do+  n <- L.get @Integer+  if n <= 0+    then pure n+    else do+      L.put (n - 1)+      programEff+{-# NOINLINE programEff #-}++countdownEff :: Integer -> (Integer, Integer)+countdownEff n = L.run . L.runState n $ programEff++countdownEffDeep :: Integer -> (Integer, Integer)+countdownEffDeep n = L.run+  . runR . runR . runR . runR . runR . runR . runR . runR . runR . runR+  . L.runState n+  . runR . runR . runR . runR . runR . runR . runR . runR . runR . runR+  $ programEff+  where+    runR = L.runReader ()++#endif++----------------------------------------+-- freer-simple++#ifdef VERSION_freer_simple++programFreerSimple :: FS.Member (FS.State Integer) es => FS.Eff es Integer+programFreerSimple = do+  n <- FS.get @Integer+  if n <= 0+    then pure n+    else do+      FS.put (n - 1)+      programFreerSimple+{-# NOINLINE programFreerSimple #-}++countdownFreerSimple :: Integer -> (Integer, Integer)+countdownFreerSimple n = FS.run . FS.runState n $ programFreerSimple++countdownFreerSimpleDeep :: Integer -> (Integer, Integer)+countdownFreerSimpleDeep n = FS.run+  . runR . runR . runR . runR . runR . runR . runR . runR . runR . runR+  . FS.runState n+  . runR . runR . runR . runR . runR . runR . runR . runR . runR . runR+  $ programFreerSimple+  where+    runR = FS.runReader ()++#endif
+ bench/Main.hs view
@@ -0,0 +1,54 @@+{-# LANGUAGE CPP #-}+module Main (main) where++import Test.Tasty.Bench++import Countdown++main :: IO ()+main = defaultMain+  [ bgroup "countdown"+    [ bgroup "reference"        $ mkCountdown nf      countdownRef+    , bgroup "shallow"+      [ bgroup "efectful (SP)"  $ mkCountdown nfAppIO countdownEffectfulStatic+      , bgroup "efectful (SM)"  $ mkCountdown nfAppIO countdownEffectfulMVar+      , bgroup "efectful (DP)"  $ mkCountdown nfAppIO countdownEffectfulDynPure+      , bgroup "efectful (DM)"  $ mkCountdown nfAppIO countdownEffectfulDynMVar+#ifdef VERSION_freer_simple+      , bgroup "freer-simple"   $ mkCountdown nf      countdownFreerSimple+#endif+#ifdef VERSION_eff+      , bgroup "eff"            $ mkCountdown nf      countdownEff+#endif+      , bgroup "mtl"            $ mkCountdown nf      countdownMtl+#ifdef VERSION_fused_effects+      , bgroup "fused-effects"  $ mkCountdown nf      countdownFusedEffects+#endif+#ifdef VERSION_polysemy+      , bgroup "polysemy"       $ mkCountdown nf      countdownPolysemy+#endif+      ]+    , bgroup "deep"+      [ bgroup "efectful (SP)"  $ mkCountdown nfAppIO countdownEffectfulStaticDeep+      , bgroup "efectful (SM)"  $ mkCountdown nfAppIO countdownEffectfulMVarDeep+      , bgroup "efectful (DP)"  $ mkCountdown nfAppIO countdownEffectfulDynPureDeep+      , bgroup "efectful (DM)"  $ mkCountdown nfAppIO countdownEffectfulDynMVarDeep+#ifdef VERSION_eff+      , bgroup "eff"            $ mkCountdown nf      countdownEffDeep+#endif+#ifdef VERSION_freer_simple+      , bgroup "freer-simple"   $ mkCountdown nf      countdownFreerSimpleDeep+#endif+#ifdef VERSION_polysemy+      , bgroup "polysemy"       $ mkCountdown nf      countdownPolysemyDeep+#endif+      , bgroup "mtl"            $ mkCountdown nf      countdownMtlDeep+#ifdef VERSION_fused_effects+      , bgroup "fused-effects"  $ mkCountdown nf      countdownFusedEffectsDeep+#endif+      ]+    ]+  ]++mkCountdown :: (nf -> Integer -> Benchmarkable) -> nf -> [Benchmark]+mkCountdown f g = map (\n -> bench (show n) $ f g n) [100, 1000, 10000]
+ effectful.cabal view
@@ -0,0 +1,129 @@+cabal-version:      2.4+build-type:         Simple+name:               effectful+version:            0.0.0.0+license:            BSD-3-Clause+license-file:       LICENSE+category:           Control+maintainer:         andrzej@rybczak.net+author:             Andrzej Rybczak+synopsis:           A simple, yet powerful extensible effects library.++description: A simple, performant extensible effects library with seamless+             integration with the existing Haskell ecosystem.++extra-source-files: CHANGELOG.md++tested-with: GHC ==8.0.2 || ==8.2.2 || ==8.4.4 || ==8.6.5 || ==8.8.4 || ==8.10.4+              || ==9.0.1 || ==9.2.0.20210422++bug-reports:   https://github.com/arybczak/effectful/issues+source-repository head+  type:     git+  location: https://github.com/arybczak/effectful.git++common language+    ghc-options:        -Wall++    default-language:   Haskell2010++    default-extensions: BangPatterns+                        ConstraintKinds+                        DataKinds+                        DefaultSignatures+                        DeriveFunctor+                        FlexibleContexts+                        FlexibleInstances+                        GADTs+                        GeneralizedNewtypeDeriving+                        LambdaCase+                        NamedFieldPuns+                        MultiParamTypeClasses+                        RankNTypes+                        RecordWildCards+                        RoleAnnotations+                        ScopedTypeVariables+                        StrictData+                        TupleSections+                        TypeApplications+                        TypeInType+                        TypeFamilies+                        TypeOperators++library+    import:         language++    build-depends:    base <5+                    , containers+                    , exceptions+                    , ghc-prim+                    , monad-control+                    , primitive+                    , resourcet+                    , transformers+                    , transformers-base+                    , unliftio-core++    hs-source-dirs:  src++    exposed-modules: Effectful+                     Effectful.Class.Reader+                     Effectful.Class.State+                     Effectful.Class.Writer+                     Effectful.Coroutine+                     Effectful.Error+                     Effectful.Internal.Env+                     Effectful.Internal.Has+                     Effectful.Internal.Monad+                     Effectful.Internal.Utils+                     Effectful.Reader+                     Effectful.Resource+                     Effectful.State+                     Effectful.State.Dynamic+                     Effectful.State.MVar+                     Effectful.Writer++test-suite test+    import:         language++    ghc-options:    -threaded -rtsopts++    build-depends:    base <5+                    , effectful+                    , exceptions+                    , lifted-async+                    , lifted-base+                    , tasty+                    , tasty-hunit+                    , unliftio++    hs-source-dirs: tests++    type:           exitcode-stdio-1.0+    main-is:        Main.hs++benchmark bench+    import:         language++    ghc-options:    -threaded -rtsopts -with-rtsopts=-T++    if impl(ghc < 9)+       build-depends: freer-simple++    if impl(ghc >= 8.2 && < 9.2)+       build-depends: fused-effects++    if impl(ghc >= 8.4 && < 9)+       build-depends: polysemy++    build-depends:    base <5+                    , effectful+                    , mtl+                    , tasty-bench++    hs-source-dirs: bench++    type:           exitcode-stdio-1.0+    main-is:        Main.hs++    other-modules:  Countdown
+ src/Effectful.hs view
@@ -0,0 +1,34 @@+module Effectful+  ( -- * The 'Eff' monad+    Eff+  , runEff+  , Effect+  , (:>)++  -- * The IO effect+  , IOE+  , runIOE++  -- * Execution of IO in effect handlers+  , impureEff+  , impureEff_++  -- * Helpers for defining new effects++  -- ** Running+  , runEffect+  , evalEffect+  , execEffect++  -- ** Retrieval and modification+  , getEffect+  , putEffect+  , stateEffect+  , localEffect+  , listenEffect+  , readerEffectM+  , stateEffectM+  ) where++import Effectful.Internal.Has+import Effectful.Internal.Monad
+ src/Effectful/Class/Reader.hs view
@@ -0,0 +1,42 @@+{-# LANGUAGE UndecidableInstances #-}+module Effectful.Class.Reader+  ( MonadReader(..)+  , asks+  ) where++import Control.Monad.Trans.Class+import Control.Monad.Trans.Control++import Effectful.Internal.Has+import Effectful.Internal.Monad+import qualified Effectful.Reader as R++-- | Compatiblity layer for a transition period from MTL-style effect handling+-- to 'Effective.Eff'.+class Monad m => MonadReader r m where+  {-# MINIMAL (ask | reader), local #-}+  ask :: m r+  ask = reader id++  local :: (r -> r) -> m a -> m a++  reader :: (r -> a) -> m a+  reader f = ask >>= pure . f++-- | Generic, overlappable instance.+instance {-# OVERLAPPABLE #-}+  ( MonadReader r m+  , MonadTransControl t+  , Monad (t m)+  ) => MonadReader r (t m) where+  ask       = lift ask+  local f m = liftWith (\run -> local f (run m)) >>= restoreT . pure+  reader    = lift . reader++instance R.Reader r :> es => MonadReader r (Eff es) where+  ask    = R.ask+  local  = R.local+  reader = R.reader++asks :: MonadReader r m => (r -> a) -> m a+asks = reader
+ src/Effectful/Class/State.hs view
@@ -0,0 +1,43 @@+{-# LANGUAGE UndecidableInstances #-}+module Effectful.Class.State where++import Control.Monad.Trans.Class++import Effectful.Internal.Has+import Effectful.Internal.Monad+import qualified Effectful.State.Dynamic as S++-- | Compatiblity layer for a transition period from MTL-style effect handling+-- to 'Effective.Eff'.+class Monad m => MonadState s m where+  {-# MINIMAL state | get, put #-}++  get :: m s+  get = state (\s -> (s, s))++  put :: s -> m ()+  put s = state (\_ -> ((), s))++  state :: (s -> (a, s)) -> m a+  state f = do+    (a, s) <- f <$> get+    s `seq` put s+    pure a++-- | Generic, overlappable instance.+instance {-# OVERLAPPABLE #-}+  ( MonadState s m+  , MonadTrans t+  , Monad (t m)+  ) => MonadState s (t m) where+  get   = lift get+  put   = lift . put+  state = lift . state++instance S.State s :> es => MonadState s (Eff es) where+  get   = S.get+  put   = S.put+  state = S.state++modify :: MonadState s m => (s -> s) -> m ()+modify f = state (\s -> ((), f s))
+ src/Effectful/Class/Writer.hs view
@@ -0,0 +1,46 @@+{-# LANGUAGE UndecidableInstances #-}+module Effectful.Class.Writer where++import Control.Monad.Trans.Class+import Control.Monad.Trans.Control++import Effectful.Internal.Has+import Effectful.Internal.Monad+import qualified Effectful.Writer as W++-- | Compatiblity layer for a transition period from MTL-style effect handling+-- to 'Effective.Eff'.+class Monad m => MonadWriter w m where+  {-# MINIMAL (writer | tell), listen #-}++  writer :: (a, w) -> m a+  writer (a, w) = do+    tell w+    pure a++  tell :: w -> m ()+  tell w = writer ((), w)++  listen :: m a -> m (a, w)++-- | Generic, overlappable instance.+instance {-# OVERLAPPABLE #-}+  ( MonadWriter w m+  , MonadTransControl t+  , Monad (t m)+  ) => MonadWriter w (t m) where+  writer   = lift . writer+  tell     = lift . tell+  listen m = do+    (stT, w) <- liftWith $ \run -> listen (run m)+    (, w) <$> restoreT (pure stT)++instance (W.Writer w :> es, Monoid w) => MonadWriter w (Eff es) where+  writer = W.writer+  tell   = W.tell+  listen = W.listen++listens :: MonadWriter w m => (w -> b) -> m a -> m (a, b)+listens f m = do+  (a, w) <- listen m+  pure (a, f w)
+ src/Effectful/Coroutine.hs view
@@ -0,0 +1,89 @@+-- | Experimental support for coroutines.+module Effectful.Coroutine+  ( Coroutine+  , Status(..)+  , runCoroutine+  , yield+  ) where++import Control.Concurrent.MVar+import Control.Exception+import Data.Function+import qualified Control.Concurrent as C++import Effectful.Internal.Env+import Effectful.Internal.Has+import Effectful.Internal.Monad++data Coroutine o i = forall es r. Coroutine+  { crInput         :: MVar (i, Env es)+  , crState         :: MVar (State o r)+  , crCallerEnvSize :: Int+  }++data Status es o i r+  = Done r+  | Yielded o (i -> Eff es (Status es o i r))++runCoroutine :: Eff (Coroutine o i : es) r -> Eff es (Status es o i r)+runCoroutine (Eff m) = impureEff $ \es -> do+  size    <- sizeEnv es+  mvInput <- newEmptyMVar+  mvState <- newEmptyMVar+  mask $ \restore -> do+    -- Create a worker thread and continue execution there.+    tid <- C.forkIO $ do+      let cr = Coroutine mvInput mvState size+      er <- try $ restore . m =<< unsafeConsEnv cr es+      tryPutMVar mvState (either Failure Success er) >>= \case+        False -> error "unexpected"+        True  -> pure ()+    waitForStatus restore es size tid mvInput mvState++yield :: Coroutine o i :> es => o -> Eff es i+yield o = impureEff $ \es -> mask $ \restore -> do+  Coroutine{..} <- getEnv es+  size <- sizeEnv es+  -- Save local part of the environment as the caller will discard it.+  localEs <- takeLastEnv (size - crCallerEnvSize) es+  -- Pass control to the caller.+  tryPutMVar crState (Yield o) >>= \case+    False -> error "unexpected"+    True  -> do+      (i, callerEs) <- restore $ takeMVar crInput+      -- The caller resumed, reconstruct the local environment. The environment+      -- needs to be replaced since the one we just got might be completely+      -- different to what we had before suspending the computation, e.g. if the+      -- computation was resumed in a different thread.+      unsafeReplaceEnv es =<< unsafeAppendEnv callerEs localEs+      pure i++----------------------------------------+-- Internal++data State o r where+  Failure :: SomeException -> State o r+  Success :: r             -> State o r+  Yield   :: o             -> State o r++waitForStatus+  :: (forall a. IO a -> IO a)+  -> Env es+  -> Int+  -> C.ThreadId+  -> MVar (i, Env es)+  -> MVar (State o r)+  -> IO (Status es o i r)+waitForStatus restore0 es0 size0 tid mvInput mvState = fix $ \loop -> do+  try @SomeException (restore0 $ takeMVar mvState) >>= \case+    Left e            -> throwTo tid e >> loop+    Right (Failure e) -> throwIO e+    Right (Success r) -> Done r      <$ unsafeTrimEnv size0 es0+    Right (Yield o)   -> Yielded o k <$ unsafeTrimEnv size0 es0+  where+    k i = impureEff $ \es -> mask $ \restore -> do+      size <- sizeEnv es+      -- Resume suspended computation with the current environment.+      tryPutMVar mvInput (i, es) >>= \case+        False -> error "unexpected"+        True  -> waitForStatus restore es size tid mvInput mvState
+ src/Effectful/Error.hs view
@@ -0,0 +1,62 @@+-- | Support for checked exceptions.+module Effectful.Error+ ( Error+ , runError+ , throwError+ , catchError+ , tryError+ ) where++import Control.Exception+import Data.Typeable+import GHC.Stack++import Effectful.Internal.Env+import Effectful.Internal.Has+import Effectful.Internal.Monad+import Effectful.Internal.Utils++type role Error nominal+data Error e = Error++runError+  :: forall e es a. Exception e+  => Eff (Error e : es) a+  -> Eff es (Either ([String], e) a)+runError (Eff m) = impureEff $ \es0 -> mask $ \release -> do+  size <- sizeEnv es0+  es <- unsafeConsEnv (Error @e) es0+  try (release $ m es) >>= \case+    Right a           -> Right a      <$ unsafeTrimEnv size es+    Left (WrapE cs e) -> Left (cs, e) <$ unsafeTrimEnv size es++throwError+  :: (HasCallStack, Exception e, Error e :> es)+  => e+  -> Eff es a+throwError e = impureEff_ $ do+  throwIO $ WrapE (ppCallStack <$> getCallStack callStack) e++catchError+  :: (Exception e, Error e :> es)+  => Eff es a+  -> ([String] -> e -> Eff es a)+  -> Eff es a+catchError (Eff m) handler = impureEff $ \es -> do+  size <- sizeEnv es+  m es `catch` \(WrapE e cs) -> do+    checkSizeEnv size es+    unEff (handler e cs) es++tryError+  :: (Exception e, Error e :> es)+  => Eff es a+  -> Eff es (Either ([String], e) a)+tryError m = (Right <$> m) `catchError` \es e -> pure (Left (es, e))++----------------------------------------+-- WrapE++data WrapE e = WrapE [String] e+  deriving Show+instance (Show e, Typeable e) => Exception (WrapE e)
+ src/Effectful/Internal/Env.hs view
@@ -0,0 +1,194 @@+{-# OPTIONS_HADDOCK not-home #-}+-- | The enviroment for 'Effective.Internal.Monad.Eff'.+--+-- This module is intended for internal use only, and may change without warning+-- in subsequent releases.+module Effectful.Internal.Env+  ( Env++  -- * Safe operations+  , emptyEnv+  , cloneEnv+  , sizeEnv+  , takeLastEnv+  , getEnv+  , checkSizeEnv++  -- * Extending and shrinking+  , unsafeReplaceEnv+  , unsafeConsEnv+  , unsafeAppendEnv+  , unsafeTrimEnv++  -- * Data retrieval and update+  , unsafePutEnv+  , unsafeModifyEnv+  , unsafeStateEnv+  ) where++import Control.Monad+import Control.Monad.Primitive+import Data.IORef+import Data.Primitive.SmallArray+import GHC.Exts (Any)+import GHC.Stack+import Unsafe.Coerce++import Effectful.Internal.Has++type role Env nominal++-- | A mutable, extensible record indexed by effect data types.+newtype Env (es :: [Effect]) = Env (IORef EnvRef)++data EnvRef = EnvRef Int (SmallMutableArray RealWorld Any)++-- | Create an empty environment.+emptyEnv :: IO (Env '[])+emptyEnv = fmap Env . newIORef . EnvRef 0+  =<< newSmallArray 0 (error "undefined field")++-- | Clone the environment.+cloneEnv :: Env es -> IO (Env es)+cloneEnv (Env ref) = do+  EnvRef n es <- readIORef ref+  fmap Env . newIORef . EnvRef n+    =<< cloneSmallMutableArray es 0 (sizeofSmallMutableArray es)++-- | Get the current size of the environment.+sizeEnv :: Env es -> IO Int+sizeEnv (Env ref) = do+  EnvRef n _ <- readIORef ref+  pure n++-- | Take last @k@ values from the top of the environment.+takeLastEnv :: HasCallStack => Int -> Env es0 -> IO (Env es)+takeLastEnv k (Env ref) = do+  EnvRef n es <- readIORef ref+  if k > n+    then error $ "k (" ++ show k ++ ") > n (" ++ show n ++ ")"+    else fmap Env . newIORef . EnvRef k =<< cloneSmallMutableArray es (n - k) k++-- | Extract a specific data type from the environment.+getEnv :: forall e es. (HasCallStack, e :> es) => Env es -> IO e+getEnv (Env ref) = do+  EnvRef n es <- readIORef ref+  fromAny <$> readSmallArray es (ixEnv @e @es n)++-- | Check that the size of the environment is the same as the expected value.+checkSizeEnv :: HasCallStack => Int -> Env es -> IO ()+checkSizeEnv k (Env ref) = do+  EnvRef n _ <- readIORef ref+  when (k /= n) . error $ "k (" ++ show k ++ ") /= n (" ++ show n ++ ")"++----------------------------------------+-- Extending and shrinking++-- | Replace the first argument with the second one in place.+unsafeReplaceEnv :: HasCallStack => Env es -> Env es -> IO ()+unsafeReplaceEnv (Env ref0) (Env ref1) = writeIORef ref0 =<< readIORef ref1++-- | Extend the environment with a new data type in place.+unsafeConsEnv :: HasCallStack => e -> Env es -> IO (Env (e : es))+unsafeConsEnv e (Env ref) = do+  EnvRef n es0 <- readIORef ref+  let len0 = sizeofSmallMutableArray es0+  case n `compare` len0 of+    GT -> error $ "n (" ++ show n ++ ") > len0 (" ++ show len0 ++ ")"+    LT -> do+      e `seq` writeSmallArray es0 n (toAny e)+      writeIORef ref $! EnvRef (n + 1) es0+    EQ -> do+      let len = doubleCapacity len0+      es <- newSmallArray len (error "undefined field")+      copySmallMutableArray es 0 es0 0 len0+      e `seq` writeSmallArray es n (toAny e)+      writeIORef ref $! EnvRef (n + 1) es+  pure $ Env ref+{-# NOINLINE unsafeConsEnv #-}++-- | Extend the first environment with the second one in place.+unsafeAppendEnv :: HasCallStack => Env es0 -> Env es1 -> IO (Env es)+unsafeAppendEnv (Env ref0) (Env ref1) = do+  EnvRef n0 es0 <- readIORef ref0+  EnvRef n1 es1 <- readIORef ref1+  let n = n0 + n1+  if n <= sizeofSmallMutableArray es0+    then do+      copySmallMutableArray es0 n0 es1 0 n1+      writeIORef ref0 $! EnvRef n es0+      pure $ Env ref0+    else do+      es <- newSmallArray n (error "undefined field")+      copySmallMutableArray es 0  es0 0 n0+      copySmallMutableArray es n0 es1 0 n1+      writeIORef ref0 $! EnvRef n es+      pure $ Env ref0+{-# NOINLINE unsafeAppendEnv #-}++-- | Trim the environment to the given size in place.+unsafeTrimEnv :: HasCallStack => Int -> Env es -> IO (Env es0)+unsafeTrimEnv k (Env ref) = do+  EnvRef n es <- readIORef ref+  if k > n+    then error $ "k (" ++ show k ++ ") > n (" ++ show n ++ ")"+    else do+      overwrite es k (n - k)+      writeIORef ref $! EnvRef k es+      pure $ Env ref+  where+    overwrite es base = \case+      0 -> pure ()+      i -> do+        writeSmallArray es (base + i - 1) (error "undefined field")+        overwrite es base (i - 1)+{-# NOINLINE unsafeTrimEnv #-}++----------------------------------------+-- Data retrieval and update++-- | Replace the data type in the environment with a new value in place.+unsafePutEnv+  :: forall e es. (HasCallStack, e :> es)+  => e+  -> Env es+  -> IO ()+unsafePutEnv e (Env ref) = do+  EnvRef n es <- readIORef ref+  e `seq` writeSmallArray es (ixEnv @e @es n) (toAny e)++-- | Modify the data type in the environment in place.+unsafeModifyEnv+  :: forall e es. (HasCallStack, e :> es)+  => (e -> e)+  -> Env es+  -> IO ()+unsafeModifyEnv f (Env ref) = do+  EnvRef n es <- readIORef ref+  let i = ixEnv @e @es n+  e <- f . fromAny <$> readSmallArray es i+  e `seq` writeSmallArray es i (toAny e)++-- | Modify the data type in the enviroment in place and return a value.+unsafeStateEnv+  :: forall e es a. (HasCallStack, e :> es)+  => (e -> (a, e))+  -> Env es -> IO a+unsafeStateEnv f (Env ref) = do+  EnvRef n es <- readIORef ref+  let i = ixEnv @e @es n+  (a, e) <- f . fromAny <$> readSmallArray es i+  e `seq` writeSmallArray es i (toAny e)+  pure a++----------------------------------------+-- Internal helpers++doubleCapacity :: Int -> Int+doubleCapacity n = max 1 n * 2++toAny :: a -> Any+toAny = unsafeCoerce++fromAny :: Any -> a+fromAny = unsafeCoerce
+ src/Effectful/Internal/Has.hs view
@@ -0,0 +1,35 @@+{-# LANGUAGE AllowAmbiguousTypes #-}+{-# LANGUAGE UndecidableInstances #-}+{-# OPTIONS_HADDOCK not-home #-}+-- | Type-safe indexing for 'Effective.Internal.Monad.Env'.+--+-- This module is intended for internal use only, and may change without warning+-- in subsequent releases.+module Effectful.Internal.Has+  ( Effect+  , (:>)+  , ixEnv+  ) where++import Data.Kind++type Effect = Type++class (e :: Effect) :> (es :: [Effect]) where+  -- | Get position of @e@ in @es@.+  --+  -- /Note:/ GHC is kind enough to cache these values as they're top level CAFs,+  -- so the lookup is amortized @O(1)@ without any language level tricks.+  ixOf :: Int+  ixOf = -- Don't show "minimal complete definition" in haddock.+         error "unimplemented"++instance {-# OVERLAPPING #-} e :> (e : es) where+  ixOf = 0++instance e :> es => e :> (x : es) where+  ixOf = 1 + ixOf @e @es++-- | Get position of @e@ in the 'Effective.Internal.Env.Env'.+ixEnv :: forall e es. e :> es => Int -> Int+ixEnv n = n - ixOf @e @es - 1
+ src/Effectful/Internal/Monad.hs view
@@ -0,0 +1,190 @@+{-# LANGUAGE UndecidableInstances #-}+{-# OPTIONS_HADDOCK not-home #-}+-- | The 'Eff' monad.+--+-- This module is intended for internal use only, and may change without warning+-- in subsequent releases.+module Effectful.Internal.Monad+  ( -- * Monad+    Eff(..)+  , runEff+  , impureEff+  , impureEff_++  -- * IO+  , IOE+  , runIOE++  -- * Helpers+  , runEffect+  , evalEffect+  , execEffect+  , getEffect+  , putEffect+  , stateEffect+  , localEffect+  , listenEffect+  , readerEffectM+  , stateEffectM+  ) where++import Control.Concurrent (myThreadId)+import Control.Monad.Base+import Control.Monad.Catch+import Control.Monad.IO.Class+import Control.Monad.IO.Unlift+import Control.Monad.Trans.Control+import GHC.Magic (oneShot)++import Effectful.Internal.Env+import Effectful.Internal.Has++type role Eff nominal representational++newtype Eff (es :: [Effect]) a = Eff { unEff :: Env es -> IO a }++runEff :: Eff '[] a -> IO a+runEff (Eff m) = m =<< emptyEnv++impureEff :: (Env es -> IO a) -> Eff es a+impureEff m = Eff (oneShot m)++impureEff_ :: IO a -> Eff es a+impureEff_ m = impureEff $ \_ -> m++----------------------------------------+-- Base++instance Functor (Eff es) where+  fmap f (Eff m) = impureEff $ \es -> f <$> m es++instance Applicative (Eff es) where+  pure = impureEff_ . pure+  Eff mf <*> Eff mx = impureEff $ \es -> mf es <*> mx es++instance Monad (Eff es) where+  Eff m >>= k = impureEff $ \es -> do+    a <- m es+    unEff (k a) es++----------------------------------------+-- Exception++instance MonadThrow (Eff es) where+  throwM e = impureEff_ $ throwM e++instance MonadCatch (Eff es) where+  catch (Eff m) handler = impureEff $ \es -> do+    size <- sizeEnv es+    m es `catch` \e -> do+      checkSizeEnv size es+      unEff (handler e) es++instance MonadMask (Eff es) where+  mask k = impureEff $ \es -> mask $ \restore ->+    unEff (k $ (\f (Eff m) -> impureEff $ f . m) restore) es++  uninterruptibleMask k = impureEff $ \es -> uninterruptibleMask $ \restore ->+    unEff (k $ (\f (Eff m) -> impureEff $ f . m) restore) es++  generalBracket acquire release use = impureEff $ \es -> mask $ \restore -> do+    size <- sizeEnv es+    resource <- unEff acquire es+    b <- restore (unEff (use resource) es) `catch` \e -> do+      checkSizeEnv size es+      _ <- unEff (release resource $ ExitCaseException e) es+      throwM e+    checkSizeEnv size es+    c <- unEff (release resource $ ExitCaseSuccess b) es+    pure (b, c)++----------------------------------------+-- IO++data IOE = IOE++runIOE :: Eff '[IOE] a -> Eff '[] a+runIOE = evalEffect IOE++instance IOE :> es => MonadIO (Eff es) where+  liftIO = impureEff_++instance IOE :> es => MonadBase IO (Eff es) where+  liftBase = impureEff_++instance IOE :> es => MonadBaseControl IO (Eff es) where+  type StM (Eff es) a = a+  liftBaseWith = runInIO+  restoreM = pure++instance IOE :> es => MonadUnliftIO (Eff es) where+  withRunInIO = runInIO++-- | Run 'Eff' computations in 'IO'.+runInIO :: ((forall r. Eff es r -> IO r) -> IO a) -> Eff es a+runInIO f = impureEff $ \es -> do+  tid0 <- myThreadId+  f $ \(Eff m) -> do+    tid <- myThreadId+    -- If the lifting function is called from a different thread, we need to+    -- clone the environment, otherwise multiple threads will attempt to modify+    -- it in different ways and things will break horribly.+    if tid0 == tid+      then m es+      else m =<< cloneEnv es++----------------------------------------+-- Helpers++runEffect :: e -> Eff (e : es) a -> Eff es (a, e)+runEffect e0 (Eff m) = impureEff $ \es0 -> do+  size <- sizeEnv es0+  bracket (unsafeConsEnv e0 es0)+          (unsafeTrimEnv size)+          (\es -> (,) <$> m es <*> getEnv es)++evalEffect :: e -> Eff (e : es) a -> Eff es a+evalEffect e (Eff m) = impureEff $ \es0 -> do+  size <- sizeEnv es0+  bracket (unsafeConsEnv e es0)+          (unsafeTrimEnv size)+          (\es -> m es)++execEffect :: e -> Eff (e : es) a -> Eff es e+execEffect e0 (Eff m) = impureEff $ \es0 -> do+  size <- sizeEnv es0+  bracket (unsafeConsEnv e0 es0)+          (unsafeTrimEnv size)+          (\es -> m es *> getEnv es)++getEffect :: e :> es => Eff es e+getEffect = impureEff $ \es -> getEnv es++putEffect :: e :> es => e -> Eff es ()+putEffect e = impureEff $ \es -> unsafePutEnv e es++stateEffect :: e :> es => (e -> (a, e)) -> Eff es a+stateEffect f = impureEff $ \es -> unsafeStateEnv f es++localEffect :: e :> es => (e -> e) -> Eff es a -> Eff es a+localEffect f (Eff m) = impureEff $ \es -> do+  bracket (unsafeStateEnv (\e -> (e, f e)) es)+          (\e -> unsafePutEnv e es)+          (\_ -> m es)++listenEffect :: (e :> es, Monoid e) => Eff es a -> Eff es (a, e)+listenEffect (Eff m) = impureEff $ \es -> mask $ \restore -> do+  e0 <- unsafeStateEnv (\e -> (e, mempty)) es+  -- If an exception is thrown, restore e0 and keep parts of e1.+  a <- restore (m es) `onException` unsafeModifyEnv (\e -> e0 `mappend` e) es+  e1 <- unsafeStateEnv (\e -> (e, e0 `mappend` e)) es+  pure (a, e1)++readerEffectM :: e :> es => (e -> Eff es a) -> Eff es a+readerEffectM f = impureEff $ \es -> getEnv es >>= \e -> unEff (f e) es++stateEffectM :: e :> es => (e -> Eff es (a, e)) -> Eff es a+stateEffectM f = impureEff $ \es -> do+  (a, e) <- (\e -> unEff (f e) es) =<< getEnv es+  unsafePutEnv e es+  pure a
+ src/Effectful/Internal/Utils.hs view
@@ -0,0 +1,16 @@+{-# OPTIONS_HADDOCK not-home #-}+-- | Miscellaneous functions.+--+-- This module is intended for internal use only, and may change without warning+-- in subsequent releases.+module Effectful.Internal.Utils+  ( ppCallStack+  ) where++import GHC.Stack.Types++-- | Pretty print a position from a 'CallStack'.+ppCallStack :: (String, SrcLoc) -> String+ppCallStack (fun, SrcLoc {..}) = fun ++ " at " ++ srcLocFile+  ++ ":" ++ show srcLocStartLine ++ ":" ++ show srcLocStartCol+  ++ " in " ++ srcLocPackage ++ ":" ++ srcLocModule
+ src/Effectful/Reader.hs view
@@ -0,0 +1,30 @@+-- | The 'Reader' as an effect.+module Effectful.Reader+  ( Reader+  , runReader+  , ask+  , local+  , reader+  , asks+  ) where++import Effectful.Internal.Has+import Effectful.Internal.Monad++-- | Provide access to a read only value of type @r@.+newtype Reader r = Reader { unReader :: r }++runReader :: r -> Eff (Reader r : es) a -> Eff es a+runReader r = evalEffect (Reader r)++ask :: Reader r :> es => Eff es r+ask = unReader <$> getEffect++local :: Reader r :> es => (r -> r) -> Eff es a -> Eff es a+local f = localEffect (Reader . f . unReader)++reader :: Reader r :> es => (r -> a) -> Eff es a+reader f = f . unReader <$> getEffect++asks :: Reader r :> es => (r -> a) -> Eff es a+asks = reader
+ src/Effectful/Resource.hs view
@@ -0,0 +1,44 @@+{-# LANGUAGE UndecidableInstances #-}+{-# OPTIONS_GHC -Wno-orphans #-}+-- | Resource management via 'R.MonadResource'.+module Effectful.Resource+  ( Resource+  , runResource++  -- * Registering and releasing resources+  , R.allocate+  , R.allocate_+  , R.register+  , R.release+  , R.unprotect+  ) where++import Control.Exception+import qualified Control.Monad.Trans.Resource as R+import qualified Control.Monad.Trans.Resource.Internal as RI++import Effectful.Internal.Env+import Effectful.Internal.Has+import Effectful.Internal.Monad++-- | Data tag for a resource effect.+newtype Resource = Resource R.InternalState++-- | Run the resource effect.+runResource :: Eff (Resource : es) a -> Eff es a+runResource (Eff m) = impureEff $ \es0 -> do+  size0 <- sizeEnv es0+  istate <- R.createInternalState+  mask $ \restore -> do+    es <- unsafeConsEnv (Resource istate) es0+    a <- restore (m es) `catch` \e -> do+      _ <- unsafeTrimEnv size0 es+      RI.stateCleanupChecked (Just e) istate+      throwIO e+    _ <- unsafeTrimEnv size0 es+    RI.stateCleanupChecked Nothing istate+    pure a++instance (IOE :> es, Resource :> es) => R.MonadResource (Eff es) where+  liftResourceT (RI.ResourceT m) = impureEff $ \es -> do+    getEnv es >>= \(Resource istate) -> m istate
+ src/Effectful/State.hs view
@@ -0,0 +1,58 @@+-- | The 'State' as an effect.+--+-- Represented as a pure value underneath, therefore:+--+-- - very fast+--+-- - not suitable for sharing between multiple threads.+--+-- If you plan to do the latter, have a look at "Effective.State.MVar" or+-- "Effective.State.Dynamic".+--+module Effectful.State+  ( State+  , runState+  , evalState+  , execState+  , get+  , put+  , state+  , modify+  , stateM+  , modifyM+  ) where++import Data.Coerce++import Effectful.Internal.Has+import Effectful.Internal.Monad++-- | Provide access to a pure, mutable state of type @s@.+newtype State s = State { unState :: s }++runState :: s -> Eff (State s : es) a -> Eff es (a, s)+runState s = coerce . runEffect (State s)++evalState :: s -> Eff (State s : es) a -> Eff es a+evalState s = evalEffect (State s)++execState :: s -> Eff (State s : es) a -> Eff es s+execState s = coerce . execEffect (State s)++get :: State s :> es => Eff es s+get = unState <$> getEffect++put :: State s :> es => s -> Eff es ()+put = putEffect . State++state :: State s :> es => (s -> (a, s)) -> Eff es a+state f = stateEffect $ \(State s0) -> let (a, s) = f s0 in (a, State s)++modify :: State s :> es => (s -> s) -> Eff es ()+modify f = state (\s -> ((), f s))++stateM :: State s :> es => (s -> Eff es (a, s)) -> Eff es a+stateM f = stateEffectM $ \(State s0) -> coerce $ f s0++modifyM :: State s :> es => (s -> Eff es s) -> Eff es ()+modifyM f = stateM (\s -> ((), ) <$> f s)
+ src/Effectful/State/Dynamic.hs view
@@ -0,0 +1,125 @@+-- | The 'State' as an effect with dynamic dispatch.+--+-- It's not clear in which situation it's beneficial to use this instead of+-- "Effective.State" or "Effective.State.MVar" as you either:+--+-- - Share state between threads and need the synchonized version.+--+-- - Don't share state between threads and are free to use the faster, pure+--   version.+--+-- However, let's include this for now.+--+module Effectful.State.Dynamic+  ( State++  -- * Pure+  , runState+  , evalState+  , execState++  -- * MVar+  , runStateMVar+  , evalStateMVar+  , execStateMVar++  -- * Operations+  , get+  , put+  , state+  , modify+  , stateM+  , modifyM+  ) where++import Control.Concurrent.MVar++import Effectful.Internal.Has+import Effectful.Internal.Monad++-- | Provide access to a mutable state of type @s@.+--+-- Whether the state is represented as a pure value or an 'MVar' depends on the+-- interpretation.+data State s = forall ref. State+  { _ref     :: ref+  , _get     :: forall es.   ref -> Eff es s+  , _put     :: forall es.   ref -> s -> Eff es ref+  , _state   :: forall es a. ref -> (s -> Eff es (a, s)) -> Eff es (a, ref)+  }++----------------------------------------+-- Pure++runState :: s -> Eff (State s : es) a -> Eff es (a, s)+runState s m = evalEffect (statePure s) $ (,) <$> m <*> get++evalState :: s -> Eff (State s : es) a -> Eff es a+evalState s = evalEffect (statePure s)++execState :: s -> Eff (State s : es) a -> Eff es s+execState s m = evalEffect (statePure s) $ m *> get++statePure :: s -> State s+statePure s0 = State+  { _ref     = s0+  , _get     = pure+  , _put     = \_ -> pure+  , _state   = \s f -> f s+  }++----------------------------------------+-- MVar++runStateMVar :: s -> Eff (State s : es) a -> Eff es (a, s)+runStateMVar s m = do+  v <- impureEff_ $ newMVar s+  evalEffect (stateMVar v) $ (,) <$> m <*> get++evalStateMVar :: s -> Eff (State s : es) a -> Eff es a+evalStateMVar s m = do+  v <- impureEff_ $ newMVar s+  evalEffect (stateMVar v) m++execStateMVar :: s -> Eff (State s : es) a -> Eff es s+execStateMVar s m = do+  v <- impureEff_ $ newMVar s+  evalEffect (stateMVar v) $ m *> get++stateMVar :: MVar s -> State s+stateMVar v0 = State+  { _ref     = v0+  , _get     = impureEff_ . readMVar+  , _put     = \v s -> impureEff_ . modifyMVar v $ \_ ->+      s `seq` pure (s, v)+  , _state   = \v f -> impureEff $ \es -> modifyMVar v $ \s0 -> do+      (a, s) <- unEff (f s0) es+      s `seq` pure (s, (a, v))+  }++----------------------------------------+-- Operations++get :: State s :> es => Eff es s+get = readerEffectM $ \State{..} -> _get _ref++put :: State s :> es => s -> Eff es ()+put s = stateEffectM $ \State{..} -> do+  ref <- _put _ref s+  pure ((), State { _ref = ref, .. })++state :: State s :> es => (s -> (a, s)) -> Eff es a+state f = stateEffectM $ \State{..} -> do+  (a, ref) <- _state _ref $ pure . f+  pure (a, State { _ref = ref, .. })++modify :: State s :> es => (s -> s) -> Eff es ()+modify f = state (\s -> ((), f s))++stateM :: State s :> es => (s -> Eff es (a, s)) -> Eff es a+stateM f = stateEffectM $ \State{..} -> do+  (a, ref) <- _state _ref f+  pure (a, State { _ref = ref, .. })++modifyM :: State s :> es => (s -> Eff es s) -> Eff es ()+modifyM f = stateM (\s -> ((), ) <$> f s)
+ src/Effectful/State/MVar.hs view
@@ -0,0 +1,71 @@+-- | The 'State' as an effect.+--+-- Represented as an MVar underneath, therefore:+--+-- - slower than "Effective.State"+--+-- - suitable for sharing between multiple threads.+--+module Effectful.State.MVar+  ( State+  , runState+  , evalState+  , execState+  , get+  , put+  , state+  , modify+  , stateM+  , modifyM+  ) where++import Control.Concurrent.MVar++import Effectful.Internal.Has+import Effectful.Internal.Monad++-- | Provide access to a synchronized, mutable state of type @s@.+newtype State s = State (MVar s)++runState :: s -> Eff (State s : es) a -> Eff es (a, s)+runState s m = do+  v <- impureEff_ $ newMVar s+  evalEffect (State v) $ (,) <$> m <*> get++evalState :: s -> Eff (State s : es) a -> Eff es a+evalState s m = do+  v <- impureEff_ $ newMVar s+  evalEffect (State v) m++execState :: s -> Eff (State s : es) a -> Eff es s+execState s m = do+  v <- impureEff_ $ newMVar s+  evalEffect (State v) $ m *> get++get :: State s :> es => Eff es s+get = do+  State v <- getEffect+  impureEff_ $ readMVar v++put :: State s :> es => s -> Eff es ()+put s = do+  State v <- getEffect+  impureEff_ . modifyMVar_ v $ \_ -> s `seq` pure s++state :: State s :> es => (s -> (a, s)) -> Eff es a+state f = do+  State v <- getEffect+  impureEff_ . modifyMVar v $ \s0 -> let (a, s) = f s0 in s `seq` pure (s, a)++modify :: State s :> es => (s -> s) -> Eff es ()+modify f = state (\s -> ((), f s))++stateM :: State s :> es => (s -> Eff es (a, s)) -> Eff es a+stateM f = do+  State v <- getEffect+  impureEff $ \es -> modifyMVar v $ \s0 -> do+    (a, s) <- unEff (f s0) es+    s `seq` pure (s, a)++modifyM :: State s :> es => (s -> Eff es s) -> Eff es ()+modifyM f = stateM (\s -> ((), ) <$> f s)
+ src/Effectful/Writer.hs view
@@ -0,0 +1,47 @@+-- | The 'Writer' as an effect.+module Effectful.Writer+  ( Writer+  , runWriter+  , execWriter+  , writer+  , tell+  , listen+  , listens+  ) where++import Data.Coerce+import qualified Data.Semigroup as S++import Effectful.Internal.Has+import Effectful.Internal.Monad++-- | Provide access to a write only value of type @w@.+newtype Writer w = Writer w+  deriving (S.Semigroup, Monoid)++runWriter :: Monoid w => Eff (Writer w : es) a -> Eff es (a, w)+runWriter = fmap coerce . runEffect mempty++execWriter :: Monoid w => Eff (Writer w : es) a -> Eff es w+execWriter = fmap coerce . execEffect mempty++writer :: (Writer w :> es, Monoid w) => (a, w) -> Eff es a+writer (a, w) = stateEffect $ \w0 -> (a, w0 `mappend` Writer w)++tell :: (Writer w :> es, Monoid w) => w -> Eff es ()+tell w = stateEffect $ \w0 -> ((), w0 `mappend` Writer w)++listen+  :: (Writer w :> es, Monoid w)+  => Eff es a+  -> Eff es (a, w)+listen = fmap (\(a, Writer w) -> (a, w)) . listenEffect++listens+  :: (Writer w :> es, Monoid w)+  => (w -> b)+  -> Eff es a+  -> Eff es (a, b)+listens f m = do+  (a, w) <- listen m+  pure (a, f w)
+ tests/Main.hs view
@@ -0,0 +1,137 @@+module Main (main) where++import Control.Concurrent.Async.Lifted+import Control.Monad.IO.Class+import Test.Tasty+import Test.Tasty.HUnit+import qualified Control.Monad.Catch as E+import qualified Control.Exception.Lifted as LE+import qualified UnliftIO.Exception as UE++import Effectful+import Effectful.State++main :: IO ()+main = defaultMain $ testGroup "effectful"+  [ testGroup "state"+    [ testCase "runState & execState" test_runState+    , testCase "evalState" test_evalState+    , testCase "stateM" test_stateM+    , testCase "deep stack" test_deepStack+    , testCase "exceptions" test_exceptions+    , testCase "concurrency" test_concurrentState+    ]+  ]++test_runState :: Assertion+test_runState = runEffIO $ do+  (end, len) <- runState (0::Int) . execState collatzStart $ collatz+  assertEqual_ "correct end" 1 end+  assertEqual_ "correct len" collatzLength len++test_evalState :: Assertion+test_evalState = runEffIO $ do+  len <- evalState (0::Int) . evalState collatzStart $ collatz *> get @Int+  assertEqual_ "correct len" collatzLength len++test_stateM :: Assertion+test_stateM = runEffIO $ do+  (a, b) <- runState "hi" . stateM $ \s -> pure (s, s ++ "!!!")+  assertEqual_ "correct a" "hi"    a+  assertEqual_ "correct b" "hi!!!" b++test_deepStack :: Assertion+test_deepStack = runEffIO $ do+  n <- evalState () . execState (0::Int) $ do+    evalState () . evalState () $ do+      evalState () $ do+        evalState () . evalState () . evalState () $ do+          modify @Int (+1)+        modify @Int (+2)+      modify @Int (+4)+    modify @Int (+8)+  assertEqual_ "n" 15 n++test_exceptions :: Assertion+test_exceptions = runEffIO $ do+  testTry   "exceptions"  E.try+  testCatch "exceptions"  E.catch+  testTry   "lifted-base" LE.try+  testCatch "lifted-base" LE.catch+  testTry   "unliftio"    UE.try+  testCatch "unliftio"    UE.catch+  where+    testTry+      :: String+      -> (forall a es. IOE :> es => Eff es a -> Eff es (Either Ex a))+      -> Eff '[IOE] ()+    testTry lib tryImpl = do+      e <- tryImpl $ runState (0::Int) action+      assertEqual_ (lib ++ " - exception caught") e (Left Ex)+      s <- execState (0::Int) $ tryImpl action+      assertEqual_ (lib ++ " - state partially updated") s 1++    testCatch+      :: String+      -> (forall a es. IOE :> es => Eff es a -> (Ex -> Eff es a) -> Eff es a)+      -> Eff '[IOE] ()+    testCatch lib catchImpl = do+      s <- execState (0::Int) $ do+        _ <- (evalState () action) `catchImpl` \Ex -> modify @Int (+4)+        modify @Int (+8)+      assertEqual_ (lib ++ " - state correctly updated") s 13++    action :: State Int :> es => Eff es ()+    action = do+      modify @Int (+1)+      _ <- E.throwM Ex+      modify @Int (+2)++test_concurrentState :: Assertion+test_concurrentState = runEffIO . evalState x $ do+  replicateConcurrently_ 2 $ do+    r <- goDownward 0+    assertEqual_ "x = n" x r+  where+    x :: Int+    x = 1000000++    goDownward :: State Int :> es => Int -> Eff es Int+    goDownward acc = get @Int >>= \case+      0 -> pure acc+      n -> do+        put $ n - 1+        goDownward $ acc + 1++----------------------------------------+-- Helpers++data Ex = Ex deriving (Eq, Show)+instance E.Exception Ex++runEffIO :: Eff '[IOE] a -> IO a+runEffIO = runEff . runIOE++assertEqual_ :: (Eq a, Show a, IOE :> es) => String -> a -> a -> Eff es ()+assertEqual_ msg expected given = liftIO $ assertEqual msg expected given++----------------------------------------++collatzStart :: Integer+collatzStart = 9780657630++collatzLength :: Int+collatzLength = 1132++-- | Tests multiple 'State'S, 'put', 'get' and 'modify'.+collatz :: (State Integer :> es, State Int :> es) => Eff es ()+collatz = get @Integer >>= \case+  1 -> pure ()+  n -> if even n+       then do put $ n `div` 2+               modify @Int (+1)+               collatz+       else do put $ 3*n + 1+               modify @Int (+1)+               collatz+{-# NOINLINE collatz #-}