fused-effects 0.3.0.0 → 0.3.1.0

raw patch · 14 files changed

+491/−17 lines, 14 filesdep +inspection-testingdep +unliftio-corenew-uploaderPVP ok

version bump matches the API change (PVP)

Dependencies added: inspection-testing, unliftio-core

API changes (from Hackage documentation)

Files

• ChangeLog.md +6/−0
• README.md +1/−1
• benchmark/Bench.hs +30/−11
• examples/Main.hs +2/−0
• examples/ReinterpretLog.hs +260/−0
• fused-effects.cabal +6/−1
• src/Control/Effect/Interpret.hs +82/−0
• src/Control/Effect/Lift.hs +7/−0
• src/Control/Effect/Pure.hs +13/−0
• src/Control/Effect/Reader.hs +11/−0
• src/Control/Effect/Resource.hs +15/−2
• src/Control/Effect/State/Lazy.hs +3/−0
• src/Control/Effect/State/Strict.hs +12/−0
• test/Control/Effect/Spec.hs +43/−2

@@ -1,3 +1,9 @@+# 0.3.1.0++- Improved speed of `Reader`, `State`, `Writer`, and `Pure` effects by defining and inlining auxiliary `Applicative` methods.+- Adds `runInterpret` & `runInterpretState` handlers in `Control.Effect.Interpret` as a convenient way to experiment with effect handlers without defining a new carrier type and `Carrier` instance. Such handlers are somewhat less efficient than custom `Carrier`s, but allow for a smooth upgrade path when more efficiency is required.+- Added `unliftio-core` as a dependency so as to provide a blessed API for unlift-style effects and a solution to the cubic-caller problem.+ # 0.3.0.0  ## Backwards-incompatible changes

@@ -273,7 +273,7 @@  Like [`freer-simple`][], `fused-effects` uses an initial encoding of library- and user-defined effects as syntax which can then be given different interpretations. In `freer-simple`, this is done with a family of interpreter functions (which cover a variety of needs, and which can be extended for more bespoke needs), whereas in `fused-effects` this is done with `Carrier` instances for `newtype`s. -(Technically, it is possible to define handlers like `freer-simple`’s `interpret` using `fused-effects`, but passing handlers in as higher-order functions defeats the fusion and inlining of `Carrier` instances which makes `fused-effects` so efficient.)+(Tho note that as of `fused-effects` 0.3.1, it is possible to define handlers using `runInterpret` in a manner analogous to `freer-simple`’s `interpret`, with the caveat that its use of higher-order functions defeats the fusion and inlining of `Carrier` instances which makes `fused-effects` so efficient.)  Unlike `fused-effects`, in `freer-simple`, scoped operations like `catchError` and `local` are implemented as interpreters, and can therefore not be given new interpretations. 

@@ -1,8 +1,9 @@-{-# LANGUAGE DeriveFunctor, FlexibleContexts, FlexibleInstances, MultiParamTypeClasses, RankNTypes, TypeApplications, TypeOperators, UndecidableInstances #-}+{-# LANGUAGE DeriveFunctor, FlexibleContexts, FlexibleInstances, LambdaCase, MultiParamTypeClasses, RankNTypes, TypeApplications, TypeOperators, UndecidableInstances #-} module Main where  import Control.Effect import Control.Effect.Carrier+import Control.Effect.Interpret import Control.Effect.Pure import Control.Effect.Writer import Control.Effect.State@@ -15,27 +16,45 @@   [     bgroup "WriterC"     [ bgroup "Cod"-      [ bench "100"       $ whnf (run . runCod pure . execWriter @(Sum Int) . runCod pure . tellLoop) 100-      , bench "1000"    $ whnf (run . runCod pure . execWriter @(Sum Int) . runCod pure . tellLoop) 1000+      [ bench "100"   $ whnf (run . runCod pure . execWriter @(Sum Int) . runCod pure . tellLoop) 100+      , bench "1000"  $ whnf (run . runCod pure . execWriter @(Sum Int) . runCod pure . tellLoop) 1000       , bench "10000" $ whnf (run . runCod pure . execWriter @(Sum Int) . runCod pure . tellLoop) 10000       ]     , bgroup "standalone"-      [ bench "100"       $ whnf (run . execWriter @(Sum Int) . tellLoop) 100-      , bench "1000"    $ whnf (run . execWriter @(Sum Int) . tellLoop) 1000+      [ bench "100"   $ whnf (run . execWriter @(Sum Int) . tellLoop) 100+      , bench "1000"  $ whnf (run . execWriter @(Sum Int) . tellLoop) 1000       , bench "10000" $ whnf (run . execWriter @(Sum Int) . tellLoop) 10000       ]     ]   ,     bgroup "Strict StateC"     [ bgroup "Cod"-      [ bench "100"       $ whnf (run . runCod pure . execState @(Sum Int) 0 . runCod pure . modLoop) 100-      , bench "1000"    $ whnf (run . runCod pure . execState @(Sum Int) 0 . runCod pure . modLoop) 1000-      , bench "10000" $ whnf (run . runCod pure . execWriter @(Sum Int) . runCod pure . tellLoop) 10000+      [ bench "100"   $ whnf (run . runCod pure . execState @(Sum Int) 0 . runCod pure . modLoop) 100+      , bench "1000"  $ whnf (run . runCod pure . execState @(Sum Int) 0 . runCod pure . modLoop) 1000+      , bench "10000" $ whnf (run . runCod pure . execState @(Sum Int) 0 . runCod pure . modLoop) 10000       ]     , bgroup "standalone"-      [ bench "100"       $ whnf (run . execState @(Sum Int) 0 . modLoop) 100-      , bench "1000"    $ whnf (run . execState @(Sum Int) 0 . modLoop) 1000-      , bench "10000" $ whnf (run . execWriter @(Sum Int) . tellLoop) 10000+      [ bench "100"   $ whnf (run . execState @(Sum Int) 0 . modLoop) 100+      , bench "1000"  $ whnf (run . execState @(Sum Int) 0 . modLoop) 1000+      , bench "10000" $ whnf (run . execState @(Sum Int) 0 . modLoop) 10000+      ]+    ]+  ,+    bgroup "InterpretC vs InterpretStateC vs StateC"+    [ bgroup "InterpretC"+      [ bench "100"   $ whnf (run . evalState @(Sum Int) 0 . runInterpret (\case { Get k -> get @(Sum Int) >>= k ; Put s k -> put s >> k }) . modLoop) 100+      , bench "1000"  $ whnf (run . evalState @(Sum Int) 0 . runInterpret (\case { Get k -> get @(Sum Int) >>= k ; Put s k -> put s >> k }) . modLoop) 1000+      , bench "10000" $ whnf (run . evalState @(Sum Int) 0 . runInterpret (\case { Get k -> get @(Sum Int) >>= k ; Put s k -> put s >> k }) . modLoop) 10000+      ]+    , bgroup "InterpretStateC"+      [ bench "100"   $ whnf (run . runInterpretState (\ s -> \case { Get k -> runState @(Sum Int) s (k s) ; Put s k -> runState s k }) 0 . modLoop) 100+      , bench "1000"  $ whnf (run . runInterpretState (\ s -> \case { Get k -> runState @(Sum Int) s (k s) ; Put s k -> runState s k }) 0 . modLoop) 1000+      , bench "10000" $ whnf (run . runInterpretState (\ s -> \case { Get k -> runState @(Sum Int) s (k s) ; Put s k -> runState s k }) 0 . modLoop) 10000+      ]+    , bgroup "StateC"+      [ bench "100"   $ whnf (run . evalState @(Sum Int) 0 . modLoop) 100+      , bench "1000"  $ whnf (run . evalState @(Sum Int) 0 . modLoop) 1000+      , bench "10000" $ whnf (run . evalState @(Sum Int) 0 . modLoop) 10000       ]     ]   ]

@@ -1,10 +1,12 @@ module Main where  import qualified Parser+import qualified ReinterpretLog import qualified Teletype import Test.Hspec  main :: IO () main = hspec $ do   Teletype.spec+  ReinterpretLog.spec   Parser.spec

@@ -0,0 +1,260 @@+-- This example shows how to reinterpret a simple, first-order "logging" effect,+-- in terms of itself, in order to change the type of the values it logs.+--+-- * First, we will define a structured log message type, which is the type our+--   application prefers to log in.+--+-- * Next, we will define a logging carrier that prints strings to stdout.+--+-- * Finally, we will bridge the two with an effect carrier that reinterprets+--   structured log messages as strings.+++{-# LANGUAGE DeriveFunctor              #-}+{-# LANGUAGE DerivingStrategies         #-}+{-# LANGUAGE FlexibleContexts           #-}+{-# LANGUAGE FlexibleInstances          #-}+{-# LANGUAGE GeneralizedNewtypeDeriving #-}+{-# LANGUAGE InstanceSigs               #-}+{-# LANGUAGE KindSignatures             #-}+{-# LANGUAGE LambdaCase                 #-}+{-# LANGUAGE MultiParamTypeClasses      #-}+{-# LANGUAGE RankNTypes                 #-}+{-# LANGUAGE ScopedTypeVariables        #-}+{-# LANGUAGE TypeApplications           #-}+{-# LANGUAGE TypeOperators              #-}+{-# LANGUAGE UndecidableInstances       #-}++module ReinterpretLog+  ( spec+  ) where++import Control.Effect+import Control.Effect.Carrier+import Control.Effect.Reader+import Control.Effect.Sum+import Control.Effect.Writer+import Control.Monad.IO.Class (MonadIO(..))+import Data.Coerce            (coerce)+import Data.Function          ((&))+import Data.Kind              (Type)+import Prelude                hiding (log)+import Test.Hspec+++--------------------------------------------------------------------------------+-- The application+--------------------------------------------------------------------------------++-- Our structured log message. In this example, we just tag a 'String' with its+-- severity, but this can be anything.+data Message+  = Debug String+  | Info String++-- Render a structured log message as a string.+renderLogMessage ::+     Message+  -> String+renderLogMessage = \case+  Debug message -> "[debug] " ++ message+  Info  message -> "[info] "  ++ message++-- The application: it logs two messages, then quits.+application ::+     ( Carrier sig m+     , Member (Log Message) sig+     )+  => m ()+application = do+  log (Debug "debug message")+  log (Info "info message")++-- The application runner. Interpret the application by:+--+-- * Reinterpreting 'Log Message' effects as 'Log String' effects.+-- * Interpreting 'Log String' effects by printing to stdout.+runApplication :: IO ()+runApplication =+  application+    -- Type inference is picking our concrete monad stack.+    --+    -- Here its type is:+    --+    --   ReinterpretLogC Message String (LogStdoutC (LiftC IO)) ()++    & reinterpretLog renderLogMessage+    -- Now its type is:+    --+    --   LogStdoutC (LiftC IO) ()++    & runLogStdout+    -- Now its type is:+    --+    --   LiftC IO ()++    & runM+    -- Now its type is:+    --+    --   IO ()+++--------------------------------------------------------------------------------+-- The logging effect+--------------------------------------------------------------------------------++-- Log an 'a', then continue with 'k'.+data Log (a :: Type) (m :: Type -> Type) (k :: Type)+  = Log a k+  deriving stock (Functor)++-- Log is a "first order" effect, so the Effect and HFunctor instance are+-- boilerplate. See https://github.com/fused-effects/fused-effects/issues/54+instance Effect (Log a) where+  handle ::+       Functor f+    => f ()+    -> (forall x. f (m x) -> n (f x))+    -> Log a m (m b)+    -> Log a n (n (f b))+  handle state handler =+    coerce . fmap (handler . ((<$ state)))++instance HFunctor (Log a) where+  hmap :: (forall x. m x -> n x) -> Log a m k -> Log a n k+  hmap _ =+    coerce++-- Log an 'a'.+log ::+     ( Carrier sig m+     , Member (Log a) sig+     )+  => a+  -> m ()+log x =+  send (Log x (pure ()))+++--------------------------------------------------------------------------------+-- The logging effect carriers+--------------------------------------------------------------------------------++-- Carrier one: log strings to stdout.+newtype LogStdoutC m a+  = LogStdoutC (m a)+  deriving newtype (Applicative, Functor, Monad, MonadIO)++instance+     -- So long as the 'm' monad can interpret the 'sig' effects (and also+     -- perform IO)...+     ( Carrier sig m+     , MonadIO m+     )+     -- ... the 'LogStdoutC m' monad can interpret 'Log String :+: sig' effects+  => Carrier (Log String :+: sig) (LogStdoutC m) where++  eff :: (Log String :+: sig) (LogStdoutC m) (LogStdoutC m a) -> LogStdoutC m a+  eff = \case+    L (Log message k) ->+      LogStdoutC $ do+        liftIO (putStrLn message)+        runLogStdout k++    R other ->+      LogStdoutC (eff (handlePure runLogStdout other))++-- The 'LogStdoutC' runner.+runLogStdout ::+     LogStdoutC m a+  -> m a+runLogStdout (LogStdoutC m) =+  m+++-- Carrier two: reinterpret a program that logs 's's into one that logs 't's+-- using a function (provided at runtime) from 's' to 't'.+newtype ReinterpretLogC s t m a+  = ReinterpretLogC { unReinterpretLogC :: ReaderC (s -> t) m a }+  deriving newtype (Applicative, Functor, Monad, MonadIO)++instance+     -- So long as the 'm' monad can interpret the 'sig' effects, one of which+     -- is 'Log t'...+     ( Carrier sig m+     , Member (Log t) sig+     )+     -- ... the 'ReinterpretLogC s t m' monad can interpret 'Log s :+: sig'+     -- effects+  => Carrier (Log s :+: sig) (ReinterpretLogC s t m) where++  eff ::+       (Log s :+: sig) (ReinterpretLogC s t m) (ReinterpretLogC s t m a)+    -> ReinterpretLogC s t m a+  eff = \case+    L (Log s k) ->+      ReinterpretLogC $ do+        f <- ask @(s -> t)+        log (f s)+        unReinterpretLogC k++    R other ->+      ReinterpretLogC (eff (R (handleCoercible other)))++-- The 'ReinterpretLogC' runner.+reinterpretLog ::+     (s -> t)+  -> ReinterpretLogC s t m a+  -> m a+reinterpretLog f =+  runReader f . unReinterpretLogC++++-- Carrier three: collect log messages in a list. This is used for writing this+-- example's test spec.+newtype CollectLogMessagesC s m a+  = CollectLogMessagesC { unCollectLogMessagesC :: WriterC [s] m a }+  deriving newtype (Applicative, Functor, Monad)++instance+     -- So long as the 'm' monad can interpret the 'sig' effects...+     ( Carrier sig m+     , Effect sig+     )+     -- ...the 'CollectLogMessagesC s m' monad can interpret 'Log s :+: sig'+     -- effects+  => Carrier (Log s :+: sig) (CollectLogMessagesC s m) where++  eff ::+       (Log s :+: sig) (CollectLogMessagesC s m) (CollectLogMessagesC s m a)+    -> CollectLogMessagesC s m a+  eff = \case+    L (Log s k) ->+      CollectLogMessagesC $ do+        tell [s]+        unCollectLogMessagesC k++    R other ->+      CollectLogMessagesC (eff (R (handleCoercible other)))++-- The 'CollectLogMessagesC' runner.+collectLogMessages ::+     CollectLogMessagesC s m a+  -> m ([s], a)+collectLogMessages =+  runWriter . unCollectLogMessagesC+++-- Test spec.+spec :: Spec+spec =+  describe "reinterpret log" $+    it "reinterprets logs" $+      ((do+          log (Debug "foo")+          log (Info "bar"))+        & reinterpretLog renderLogMessage+        & collectLogMessages+        & run)+      `shouldBe` (["[debug] foo", "[info] bar"], ())

@@ -1,5 +1,5 @@ name:                fused-effects-version:             0.3.0.0+version:             0.3.1.0 synopsis:            A fast, flexible, fused effect system. description:         A fast, flexible, fused effect system, à la Effect Handlers in Scope, Monad Transformers and Modular Algebraic Effects: What Binds Them Together, and Fusion for Free—Efficient Algebraic Effect Handlers. homepage:            https://github.com/fused-effects/fused-effects@@ -27,6 +27,7 @@                      , Control.Effect.Error                      , Control.Effect.Fail                      , Control.Effect.Fresh+                     , Control.Effect.Interpret                      , Control.Effect.Lift                      , Control.Effect.NonDet                      , Control.Effect.Pure@@ -44,6 +45,7 @@   build-depends:       base >=4.9 && <4.13                      , deepseq >=1.4.3 && <1.5                      , MonadRandom >=0.5 && <0.6+                     , unliftio-core >= 0.1.2                      , random                      , transformers   hs-source-dirs:      src@@ -59,11 +61,13 @@   type:                exitcode-stdio-1.0   main-is:             Main.hs   other-modules:       Parser+                     , ReinterpretLog                      , Teletype   build-depends:       base >=4.9 && <4.13                      , fused-effects                      , hspec >=2.4.1                      , QuickCheck >= 2.7 && < 3+                     , transformers   hs-source-dirs:      examples   default-language:    Haskell2010 @@ -75,6 +79,7 @@   build-depends:       base >=4.9 && <4.13                      , fused-effects                      , hspec >=2.4.1+                     , inspection-testing >= 0.4 && <1   hs-source-dirs:      test   default-language:    Haskell2010 

@@ -0,0 +1,82 @@+{-# LANGUAGE GeneralizedNewtypeDeriving, MultiParamTypeClasses, RankNTypes, TypeOperators, UndecidableInstances #-}+module Control.Effect.Interpret+( runInterpret+, InterpretC(..)+, runInterpretState+, InterpretStateC(..)+) where++import Control.Applicative (Alternative(..))+import Control.Effect.Carrier+import Control.Effect.Reader+import Control.Effect.State+import Control.Effect.Sum+import Control.Monad (MonadPlus(..))+import Control.Monad.Fail+import Control.Monad.IO.Class+import Control.Monad.Trans.Class++-- | Interpret an effect using a higher-order function.+--+--   This involves a great deal less boilerplate than defining a custom 'Carrier' instance, at the expense of somewhat less performance. It’s a reasonable starting point for new interpretations, and if more performance or flexibility is required, it’s straightforward to “graduate” by replacing the relevant 'runInterpret' handlers with specialized 'Carrier' instances for the effects.+--+--   At time of writing, a simple passthrough use of 'runInterpret' to handle a 'State' effect is about five times slower than using 'StateC' directly.+--+--   prop> run (runInterpret (\ op -> case op of { Get k -> k a ; Put _ k -> k }) get) == a+runInterpret :: (forall x . eff m (m x) -> m x) -> InterpretC eff m a -> m a+runInterpret handler = runReader (Handler handler) . runInterpretC++newtype InterpretC eff m a = InterpretC { runInterpretC :: ReaderC (Handler eff m) m a }+  deriving (Alternative, Applicative, Functor, Monad, MonadFail, MonadIO, MonadPlus)++instance MonadTrans (InterpretC eff) where+  lift = InterpretC . lift+  {-# INLINE lift #-}++newtype Handler eff m = Handler (forall x . eff m (m x) -> m x)++runHandler :: HFunctor eff => Handler eff m -> eff (InterpretC eff m) (InterpretC eff m a) -> m a+runHandler h@(Handler handler) = handler . handlePure (runReader h . runInterpretC)++instance (HFunctor eff, Carrier sig m) => Carrier (eff :+: sig) (InterpretC eff m) where+  eff (L op) = do+    handler <- InterpretC ask+    lift (runHandler handler op)+  eff (R other) = InterpretC (eff (R (handleCoercible other)))+  {-# INLINE eff #-}+++-- | Interpret an effect using a higher-order function with some state variable.+--+--   This involves a great deal less boilerplate than defining a custom 'Carrier' instance, at the expense of somewhat less performance. It’s a reasonable starting point for new interpretations, and if more performance or flexibility is required, it’s straightforward to “graduate” by replacing the relevant 'runInterpretState' handlers with specialized 'Carrier' instances for the effects.+--+--   At time of writing, a simple use of 'runInterpretState' to handle a 'State' effect is about four times slower than using 'StateC' directly.+--+--   prop> run (runInterpretState (\ s op -> case op of { Get k -> runState s (k s) ; Put s' k -> runState s' k }) a get) == a+runInterpretState :: (forall x . s -> eff (StateC s m) (StateC s m x) -> m (s, x)) -> s -> InterpretStateC eff s m a -> m (s, a)+runInterpretState handler state = runState state . runReader (HandlerState (\ eff -> StateC (\ s -> handler s eff))) . runInterpretStateC++newtype InterpretStateC eff s m a = InterpretStateC { runInterpretStateC :: ReaderC (HandlerState eff s m) (StateC s m) a }+  deriving (Alternative, Applicative, Functor, Monad, MonadFail, MonadIO, MonadPlus)++instance MonadTrans (InterpretStateC eff s) where+  lift = InterpretStateC . lift . lift+  {-# INLINE lift #-}++newtype HandlerState eff s m = HandlerState (forall x . eff (StateC s m) (StateC s m x) -> StateC s m x)++runHandlerState :: HFunctor eff => HandlerState eff s m -> eff (InterpretStateC eff s m) (InterpretStateC eff s m a) -> StateC s m a+runHandlerState h@(HandlerState handler) = handler . handlePure (runReader h . runInterpretStateC)++instance (HFunctor eff, Carrier sig m, Effect sig) => Carrier (eff :+: sig) (InterpretStateC eff s m) where+  eff (L op) = do+    handler <- InterpretStateC ask+    InterpretStateC (lift (runHandlerState handler op))+  eff (R other) = InterpretStateC (eff (R (R (handleCoercible other))))+  {-# INLINE eff #-}+++-- $setup+-- >>> import Test.QuickCheck+-- >>> import Control.Effect.Pure+-- >>> import Control.Effect.State

@@ -12,6 +12,7 @@ import Control.Monad (MonadPlus(..)) import Control.Monad.Fail import Control.Monad.IO.Class+import Control.Monad.IO.Unlift import Control.Monad.Trans.Class import Data.Coerce @@ -44,3 +45,9 @@  instance Monad m => Carrier (Lift m) (LiftC m) where   eff = LiftC . (>>= runLiftC) . unLift++instance MonadUnliftIO m => MonadUnliftIO (LiftC m) where+  askUnliftIO = LiftC $ withUnliftIO $ \u -> return (UnliftIO (unliftIO u . runLiftC))+  {-# INLINE askUnliftIO #-}+  withRunInIO inner = LiftC $ withRunInIO $ \run -> inner (run . runLiftC)+  {-# INLINE withRunInIO #-}

@@ -5,6 +5,7 @@ , PureC(..) ) where +import Control.Applicative import Control.Effect.Carrier import Data.Coerce @@ -31,12 +32,24 @@   fmap = coerce   {-# INLINE fmap #-} +  a <$ _ = pure a+  {-# INLINE (<$) #-}+ instance Applicative PureC where   pure = PureC   {-# INLINE pure #-}    (<*>) = coerce   {-# INLINE (<*>) #-}++  liftA2 = coerce+  {-# INLINE liftA2 #-}++  _ *> b = b+  {-# INLINE (*>) #-}++  a <* _ = a+  {-# INLINE (<*) #-}  instance Monad PureC where   return = pure

@@ -14,6 +14,7 @@ import Control.Monad (MonadPlus(..)) import Control.Monad.Fail import Control.Monad.IO.Class+import Control.Monad.IO.Unlift import Control.Monad.Trans.Class import Prelude hiding (fail) @@ -66,6 +67,10 @@   {-# INLINE pure #-}   ReaderC f <*> ReaderC a = ReaderC (liftA2 (<*>) f a)   {-# INLINE (<*>) #-}+  ReaderC u *> ReaderC v = ReaderC $ \ r -> u r *> v r+  {-# INLINE (*>) #-}+  ReaderC u <* ReaderC v = ReaderC $ \ r -> u r <* v r+  {-# INLINE (<*) #-}  instance Alternative m => Alternative (ReaderC r m) where   empty = ReaderC (const empty)@@ -90,6 +95,12 @@ instance MonadTrans (ReaderC r) where   lift = ReaderC . const   {-# INLINE lift #-}++instance MonadUnliftIO m => MonadUnliftIO (ReaderC r m) where+  askUnliftIO = ReaderC $ \r -> withUnliftIO $ \u -> pure (UnliftIO (\(ReaderC x) -> unliftIO u (x r)))+  {-# INLINE askUnliftIO #-}+  withRunInIO inner = ReaderC $ \r -> withRunInIO $ \go -> inner (go . runReader r)+  {-# INLINE withRunInIO #-}  instance Carrier sig m => Carrier (Reader r :+: sig) (ReaderC r m) where   eff (L (Ask       k)) = ReaderC (\ r -> runReader r (k r))

@@ -1,4 +1,4 @@-{-# LANGUAGE DeriveFunctor, ExistentialQuantification, FlexibleContexts, FlexibleInstances, GeneralizedNewtypeDeriving, MultiParamTypeClasses, RankNTypes, StandaloneDeriving, TypeOperators, UndecidableInstances #-}+{-# LANGUAGE DeriveFunctor, ExistentialQuantification, FlexibleContexts, FlexibleInstances, GeneralizedNewtypeDeriving, MultiParamTypeClasses, RankNTypes, ScopedTypeVariables, StandaloneDeriving, TypeApplications, TypeOperators, UndecidableInstances #-} module Control.Effect.Resource ( Resource(..) , bracket@@ -6,6 +6,7 @@ , finally , onException , runResource+, withResource , ResourceC(..) ) where @@ -17,6 +18,7 @@ import           Control.Monad (MonadPlus(..)) import           Control.Monad.Fail import           Control.Monad.IO.Class+import           Control.Monad.IO.Unlift import           Control.Monad.Trans.Class  data Resource m k@@ -73,13 +75,24 @@         -> m a onException act end = bracketOnError (pure ()) (const end) (const act) -runResource :: (forall x . m x -> IO x)+runResource :: (forall x . m x -> IO x) -- ^ "unlifting" function to run the carrier in 'IO'             -> ResourceC m a             -> m a runResource handler = runReader (Handler handler) . runResourceC +-- | A helper for 'runResource' that uses 'withRunInIO' to automatically+-- select a correct unlifting function.+withResource :: MonadUnliftIO m+               => ResourceC m a+               -> m a+withResource r = withRunInIO (\f -> runHandler (Handler f) r)+ newtype ResourceC m a = ResourceC { runResourceC :: ReaderC (Handler m) m a }   deriving (Alternative, Applicative, Functor, Monad, MonadFail, MonadIO, MonadPlus)++instance MonadUnliftIO m => MonadUnliftIO (ResourceC m) where+  askUnliftIO = ResourceC . ReaderC $ \(Handler h) ->+    withUnliftIO $ \u -> pure (UnliftIO $ \r -> unliftIO u (runResource h r))  instance MonadTrans ResourceC where   lift = ResourceC . lift

@@ -30,11 +30,14 @@  instance (Functor m, Monad m) => Applicative (StateC s m) where   pure a = StateC $ \ s -> pure (s, a)+  {-# INLINE pure #-}   StateC mf <*> StateC mx = StateC $ \ s -> do     ~(s', f) <- mf s     ~(s'', x) <- mx s'     return (s'', f x)   {-# INLINE (<*>) #-}+  m *> k = m >>= \_ -> k+  {-# INLINE (*>) #-}  instance Monad m => Monad (StateC s m) where   m >>= k  = StateC $ \ s -> do

@@ -46,37 +46,49 @@  instance Monad m => Applicative (StateC s m) where   pure a = StateC (\ s -> pure (s, a))+  {-# INLINE pure #-}   StateC f <*> StateC a = StateC $ \ s -> do     (s', f') <- f s     (s'', a') <- a s'     let fa = f' a'     fa `seq` pure (s'', fa)+  {-# INLINE (<*>) #-}+  m *> k = m >>= \_ -> k+  {-# INLINE (*>) #-}  instance (Alternative m, Monad m) => Alternative (StateC s m) where   empty = StateC (const empty)+  {-# INLINE empty #-}   StateC l <|> StateC r = StateC (\ s -> l s <|> r s)+  {-# INLINE (<|>) #-}  instance Monad m => Monad (StateC s m) where   StateC m >>= f = StateC $ \ s -> do     (s', a) <- m s     let fa = f a     fa `seq` runState s' fa+  {-# INLINE (>>=) #-}  instance MonadFail m => MonadFail (StateC s m) where   fail s = StateC (const (fail s))+  {-# INLINE fail #-}  instance MonadIO m => MonadIO (StateC s m) where   liftIO io = StateC (\ s -> (,) s <$> liftIO io)+  {-# INLINE liftIO #-}  instance (Alternative m, Monad m) => MonadPlus (StateC s m)  instance MonadTrans (StateC s) where   lift m = StateC (\ s -> (,) s <$> m)+  {-# INLINE lift #-}  instance (Carrier sig m, Effect sig) => Carrier (State s :+: sig) (StateC s m) where   eff (L (Get   k)) = StateC (\ s -> runState s (k s))   eff (L (Put s k)) = StateC (\ _ -> runState s k)   eff (R other)     = StateC (\ s -> eff (handle (s, ()) (uncurry runState) other))+  {-# INLINE eff #-}+  -- $setup -- >>> :seti -XFlexibleContexts

@@ -1,21 +1,25 @@-{-# LANGUAGE FlexibleContexts, FlexibleInstances, GeneralizedNewtypeDeriving, MultiParamTypeClasses, TypeOperators, UndecidableInstances #-}+{-# LANGUAGE FlexibleContexts, FlexibleInstances, GeneralizedNewtypeDeriving, MultiParamTypeClasses, MultiWayIf, TemplateHaskell, TypeApplications, TypeOperators, UndecidableInstances #-}+{-# OPTIONS_GHC -O2 -fplugin Test.Inspection.Plugin #-} module Control.Effect.Spec where  import Control.Effect import Control.Effect.Carrier+import Control.Effect.Error import Control.Effect.Fail import Control.Effect.Reader import Control.Effect.State import Control.Effect.Sum import Prelude hiding (fail) import Test.Hspec+import Test.Inspection as Inspection+import Test.Inspection.Plugin  spec :: Spec spec = do   inference   reinterpretation   interposition-+  fusion  inference :: Spec inference = describe "inference" $ do@@ -80,3 +84,40 @@   eff op     | Just (Fail s) <- prj op = InterposeC (send (Fail ("hello, " ++ s)))     | otherwise               = InterposeC (eff (handleCoercible op))+++shouldSucceed :: Inspection.Result -> Expectation+shouldSucceed (Success _) = pure ()+shouldSucceed (Failure f) = expectationFailure f++fusion :: Spec+fusion = describe "fusion" $ do+  it "eliminates StateCs" $ do+    shouldSucceed $(inspectTest $ 'countDown `doesNotUse` ''StateC)++  it "eliminates nested StateCs" $ do+    shouldSucceed $(inspectTest $ 'countBoth `doesNotUse` ''StateC)++  it "eliminates catch and throw" $ do+    shouldSucceed $(inspectTest $ 'throwing `doesNotUse` ''ErrorC)++  it "eliminates calls to eff" $ do+    shouldSucceed $(inspectTest $ 'countDown `doesNotUse` 'eff)++countDown :: Int -> (Int, Int)+countDown start = run . runState start $ go+  where go = get >>= \n -> if n <= 0 then pure n else modify @Int pred *> go++countBoth :: Int -> (Int, (Float, ()))+countBoth n = run . runState n . runState (fromIntegral n) $ go where+  go = do+    int <- get @Int+    if+      | n == 0         -> pure ()+      | n `mod` 2 == 0 -> modify @Float (+ 1) *> modify @Int pred *> go+      | otherwise     -> modify @Int pred    *> go++throwing :: Int -> Either Int String+throwing n = run $ runError go+  where go = if n > 10 then throwError @Int 42 else pure "fine"+