simple-effects 0.10.0.2 → 0.11.0.0

raw patch · 5 files changed

+191/−19 lines, 5 filesPVP ok

version bump matches the API change (PVP)

API changes (from Hackage documentation)

Files

• simple-effects.cabal +2/−1
• src/Control/Effects.hs +3/−1
• src/Control/Effects/Resource.hs +163/−0
• src/Control/Monad/Runnable.hs +16/−16
• test/Main.hs +7/−1

@@ -1,5 +1,5 @@ name:                simple-effects
-version:             0.10.0.2
+version:             0.11.0.0
 synopsis:            A simple effect system that integrates with MTL
 description:         Please see the tutorial modules
 homepage:            https://gitlab.com/LukaHorvat/simple-effects
@@ -23,6 +23,7 @@                      , Control.Effects.Generic
                      , Control.Effects.Async
                      , Control.Effects.Yield
+                     , Control.Effects.Resource
                      , Control.Monad.Runnable
                      , Tutorial.T1_Introduction
                      , Tutorial.T2_Details

@@ -33,6 +33,8 @@ 
 class (Effect e, Monad m) => MonadEffect e m where
     effect :: EffMethods e m
+    default effect :: (MonadEffect e m', Monad (t m'), CanLift e t, t m' ~ m) => EffMethods e m
+    effect = liftThrough effect
 
 instance {-# OVERLAPPABLE #-}
     (MonadEffect e m, Monad (t m), CanLift e t)
@@ -59,7 +61,7 @@     restoreM = RuntimeImplemented . restoreM
 
 instance RunnableTrans (RuntimeImplemented e) where
-    type TransformerResult (RuntimeImplemented e) m a = a
+    type TransformerResult (RuntimeImplemented e) a = a
     type TransformerState (RuntimeImplemented e) m = EffMethods e m
     currentTransState = RuntimeImplemented ask
     restoreTransState = return

@@ -0,0 +1,163 @@+{-# LANGUAGE ScopedTypeVariables, RankNTypes, TypeFamilies, MultiParamTypeClasses, LambdaCase #-}
+{-# LANGUAGE FlexibleContexts, InstanceSigs, NoMonomorphismRestriction, FlexibleInstances #-}
+{-# LANGUAGE DataKinds, UndecidableInstances, TypeOperators, StandaloneDeriving, DeriveAnyClass #-}
+{-# LANGUAGE ConstraintKinds #-}
+-- | Provides the 'Bracket' effect for handing resource acquisition and safe cleanup.
+module Control.Effects.Resource where
+
+import Import hiding (bracket)
+import Control.Effects
+import Control.Monad.Runnable
+import qualified Control.Exception as Ex
+import GHC.TypeLits
+import qualified Control.Monad.Trans.State.Strict as SS
+import qualified Control.Monad.Trans.State.Lazy as LS
+import qualified Control.Monad.Trans.Writer.Strict as SW
+import qualified Control.Monad.Trans.Writer.Lazy as LW
+import qualified Control.Monad.Trans.RWS.Strict as SR
+import qualified Control.Monad.Trans.RWS.Lazy as LR
+import ListT
+
+-- | Class of transformers that don't introduce additional exit points to a computation.
+--
+-- Examples: @'StateT' s@, @'ReaderT' e@, 'IdentityT'
+--
+-- Counter-examples: @'ExceptT' e@, @'ErrorT' e@, 'MaybeT', 'ListT'
+class Unexceptional (t :: (* -> *) -> * -> *)
+
+data Bracket
+instance Effect Bracket where
+    data EffMethods Bracket m = BracketMethods
+        { _bracket ::
+            forall resource result cleanupRes.
+            m resource -> (resource -> Maybe result -> m cleanupRes) -> (resource -> m result) -> m result }
+    type CanLift Bracket t = (RunnableTrans t, Unexceptional t)
+    liftThrough :: forall m t. (RunnableTrans t, Monad (t m), Monad m)
+        => EffMethods Bracket m -> EffMethods Bracket (t m)
+    liftThrough (BracketMethods f) = BracketMethods g
+        where
+        g :: forall a b c. t m a -> (a -> Maybe c -> t m b) -> (a -> t m c) -> t m c
+        g acq cleanup use = do
+            st <- currentTransState
+            res <- lift (f
+                (runTransformer acq st)
+                (\tra mtrc -> flip runTransformer st $ do
+                    a <- restoreTransState tra
+                    c <- case mtrc of
+                        Nothing -> return Nothing
+                        Just trc -> Just <$> restoreTransState trc
+                    cleanup a c)
+                (\tra -> flip runTransformer st $ do
+                    a <- restoreTransState tra
+                    use a))
+            restoreTransState res
+    mergeContext mm = BracketMethods $ \acq cln use -> do
+        BracketMethods f <- mm
+        f acq cln use
+
+-- | @'bracket' acq cln use@ acquires the resource by running @acq@.
+-- If this computation aborts, the exception won't be handled and no cleanup will be performed since
+-- the resource wasn't acquired. Then @use@ is called with the resource. Regardless if @use@ threw
+-- an exception/aborted or finished normally, @cln@ is called with the resource and possibly with
+-- the result of @use@ (if it didn't abort). If there was an exception, it's rethrown: bracket
+-- is not meant to be used for exception handling.
+--
+-- An exception in this context is anything from actual @IO@ exceptions for pure ones \"thrown\" by
+-- 'ExceptT' or 'MaybeT'. In case of 'IO', the resource acquisition and cleanup are masked from
+-- async exceptions.
+--
+-- Since this function can be used on almost any transformer stack, care needs to be taken that
+-- all the transformers that /can/ throw exceptions get handled. This is why the effect isn't
+-- implicitly lifted through unknown transformers, only though ones that are instances of
+-- 'Unexceptional'. If your transformer doesn't introduce new exit points, give it an instance of
+-- that class. There are no methods to implement.
+bracket :: MonadEffect Bracket m =>
+    m resource -> (resource -> Maybe result -> m cleanupRes) -> (resource -> m result) -> m result
+BracketMethods bracket = effect
+
+-- | Use bracketing and masking for IO exceptions
+instance MonadEffect Bracket IO where
+    effect = BracketMethods $ \acq cln use -> Ex.mask $ \unmasked -> do
+        resource <- acq
+        b <- unmasked (use resource) `Ex.catch` \(e :: SomeException) -> do
+            _ <- cln resource Nothing
+            throwM e
+        _ <- cln resource (Just b)
+        return b
+
+-- | Identity can't throw or acquire in a meaningful way
+instance MonadEffect Bracket Identity where
+    effect = BracketMethods $ \acq _ use -> do
+        res <- acq
+        use res
+
+-- | Source: http://hackage.haskell.org/package/exceptions-0.10.0/docs/src/Control-Monad-Catch.html#line-674
+instance MonadEffect Bracket m => MonadEffect Bracket (ExceptT e m) where
+    effect = BracketMethods $ \acq cln use -> do
+        eres <- lift $ bracket
+            (runExceptT acq)
+            (\eres exitCase -> case eres of
+                Left e -> return (Left e) -- nothing to release, acquire didn't succeed
+                Right res -> case exitCase of
+                    Just (Right b) -> runExceptT (cln res (Just b))
+                    _ -> runExceptT (cln res Nothing))
+            (\case
+                Right res -> runExceptT $ use res
+                Left e -> return (Left e))
+        case eres of
+            Left e -> throwE e
+            Right res -> return res
+
+instance MonadEffect Bracket m => MonadEffect Bracket (MaybeT m) where
+    effect = BracketMethods $ \acq cln use -> do
+        eres <- lift $ bracket
+            (runMaybeT acq)
+            (\mres exitCase -> case mres of
+                Nothing -> return Nothing
+                Just res -> case exitCase of
+                    Just (Just b) -> runMaybeT (cln res (Just b))
+                    _ -> runMaybeT (cln res Nothing))
+            (\case
+                Just res -> runMaybeT $ use res
+                Nothing -> return Nothing)
+        case eres of
+            Nothing -> mzero
+            Just res -> return res
+
+-- | Warn about unknown transformers with a type error.
+instance {-# OVERLAPPABLE #-} UnexceptionalError t => Unexceptional t
+instance Unexceptional (SS.StateT s)
+instance Unexceptional (LS.StateT s)
+instance Unexceptional (SW.WriterT s)
+instance Unexceptional (LW.WriterT s)
+instance Unexceptional (SR.RWST r w s)
+instance Unexceptional (LR.RWST r w s)
+instance Unexceptional IdentityT
+instance Unexceptional (ReaderT r)
+instance Unexceptional ListT
+
+
+
+
+-- | A simpler version of 'bracket' that doesn't use the results of the parameters.
+bracket_ :: MonadEffect Bracket m => m resource -> m cleanupRes -> m result -> m result
+bracket_ ack cln use = bracket ack (\_ _ -> cln) (const use)
+
+type family UnexceptionalError (t :: (* -> *) -> * -> *) :: Constraint where
+    UnexceptionalError ListT = TypeError
+        ( 'Text "ListT is an exceptional transformer since it can produce zero results. The reason \
+        \why it isn't handled like ExceptT or MaybeT is because it's unclear what the behavior should \
+        \be:"
+        ':$$: 'Text "Firstly, it might acquire more than one resource. Is that expected?"
+        ':$$: 'Text "More importantly, it may produce more than one result of using a single \
+        \resource. How many times should the cleanup function be called then?"
+        ':$$: 'Text "Also, should all the resources be acquired at the beginning and released at \
+        \the end, or should they be processed one by one?"
+        ':$$: 'Text "If you need this instance, please let me know what you think should happen." )
+    UnexceptionalError t = TypeError
+        ( 'Text "The Bracket effect doesn't know about the transformer " ':<>: 'ShowType t ':$$:
+          'Text "While the effect can be used with any transformer that has a RunnableTrans instance, \
+          \it's dangerous to do so implicitly because the transformer might introduce an additional \
+          \exit point to the computation (like IO, MaybeT, ExceptT and friends do)" ':$$:
+          'Text "If you're sure that it doesn't, give it an 'Unexceptional' instance:" ':$$:
+          'Text "instance Unexceptional (" ':<>: 'ShowType t ':<>: 'Text ")" )

@@ -62,14 +62,14 @@     -- | The type of value that needs to be provided to run this transformer.
     type TransformerState t (m :: * -> *) :: *
     -- | The type of the result you get when you run this transformer.
-    type TransformerResult t (m :: * -> *) a :: *
+    type TransformerResult t a :: *
     -- | Get the current state value.
     currentTransState :: Monad m => t m (TransformerState t m)
     -- | If given a result, reconstruct the computation.
-    restoreTransState :: Monad m => TransformerResult t m a -> t m a
+    restoreTransState :: Monad m => TransformerResult t a -> t m a
     -- | Given the required state value and a computation, run the effects of the transformer
     --   in the underlying monad.
-    runTransformer :: Monad m => t m a -> TransformerState t m -> m (TransformerResult t m a)
+    runTransformer :: Monad m => t m a -> TransformerState t m -> m (TransformerResult t a)
 
 instance Runnable Identity where
     type MonadicState Identity = ()
@@ -89,7 +89,7 @@ 
 instance (Runnable m, RunnableTrans t, Monad (t m)) => Runnable (t m) where
     type MonadicState (t m) = (TransformerState t m, MonadicState m)
-    type MonadicResult (t m) a = MonadicResult m (TransformerResult t m a)
+    type MonadicResult (t m) a = MonadicResult m (TransformerResult t a)
     currentMonadicState = (,) <$> currentTransState <*> lift currentMonadicState
     restoreMonadicState s = lift (restoreMonadicState s) >>= restoreTransState
     runMonad (s, s') t = runMonad s' (runTransformer t s)
@@ -99,63 +99,63 @@ 
 instance RunnableTrans (SS.StateT s) where
     type TransformerState (SS.StateT s) m = s
-    type TransformerResult (SS.StateT s) m a = (a, s)
+    type TransformerResult (SS.StateT s) a = (a, s)
     currentTransState = get
     restoreTransState (a, s) = put s >> return a
     runTransformer = SS.runStateT
 
 instance RunnableTrans (LS.StateT s) where
     type TransformerState (LS.StateT s) m = s
-    type TransformerResult (LS.StateT s) m a = (a, s)
+    type TransformerResult (LS.StateT s) a = (a, s)
     currentTransState = get
     restoreTransState (a, s) = put s >> return a
     runTransformer = LS.runStateT
 
 instance Monoid s => RunnableTrans (SW.WriterT s) where
     type TransformerState (SW.WriterT s) m = ()
-    type TransformerResult (SW.WriterT s) m a = (a, s)
+    type TransformerResult (SW.WriterT s) a = (a, s)
     currentTransState = return ()
     restoreTransState (a, s) = SW.tell s >> return a
     runTransformer m _ = SW.runWriterT m
 
 instance Monoid s => RunnableTrans (LW.WriterT s) where
     type TransformerState (LW.WriterT s) m = ()
-    type TransformerResult (LW.WriterT s) m a = (a, s)
+    type TransformerResult (LW.WriterT s) a = (a, s)
     currentTransState = return ()
     restoreTransState (a, s) = LW.tell s >> return a
     runTransformer m _ = LW.runWriterT m
 
 instance RunnableTrans (ReaderT s) where
     type TransformerState (ReaderT s) m = s
-    type TransformerResult (ReaderT s) m a = a
+    type TransformerResult (ReaderT s) a = a
     currentTransState = ask
     restoreTransState = return
     runTransformer = runReaderT
 
 instance Monoid w => RunnableTrans (SR.RWST r w s) where
     type TransformerState (SR.RWST r w s) m = (r, s)
-    type TransformerResult (SR.RWST r w s) m a = (a, s, w)
+    type TransformerResult (SR.RWST r w s) a = (a, s, w)
     currentTransState = (,) <$> ask <*> get
     restoreTransState (a, s, w) = SR.tell w >> put s >> return a
     runTransformer m (r, s) = SR.runRWST m r s
 
 instance Monoid w => RunnableTrans (LR.RWST r w s) where
     type TransformerState (LR.RWST r w s) m = (r, s)
-    type TransformerResult (LR.RWST r w s) m a = (a, s, w)
+    type TransformerResult (LR.RWST r w s) a = (a, s, w)
     currentTransState = (,) <$> ask <*> get
     restoreTransState (a, s, w) = LR.tell w >> put s >> return a
     runTransformer m (r, s) = LR.runRWST m r s
 
 instance RunnableTrans IdentityT where
     type TransformerState IdentityT m = ()
-    type TransformerResult IdentityT m a = a
+    type TransformerResult IdentityT a = a
     currentTransState = return ()
     restoreTransState = return
     runTransformer m () = runIdentityT m
 
 instance Error e => RunnableTrans (ErrorT e) where
     type TransformerState (ErrorT e) m = ()
-    type TransformerResult (ErrorT e) m a = Either e a
+    type TransformerResult (ErrorT e) a = Either e a
     currentTransState = return ()
     restoreTransState (Left e) = throwError e
     restoreTransState (Right a) = return a
@@ -163,7 +163,7 @@ 
 instance RunnableTrans (ExceptT e) where
     type TransformerState (ExceptT e) m = ()
-    type TransformerResult (ExceptT e) m a = Either e a
+    type TransformerResult (ExceptT e) a = Either e a
     currentTransState = return ()
     restoreTransState (Left e) = throwE e
     restoreTransState (Right a) = return a
@@ -171,7 +171,7 @@ 
 instance RunnableTrans MaybeT where
     type TransformerState MaybeT m = ()
-    type TransformerResult MaybeT m a = Maybe a
+    type TransformerResult MaybeT a = Maybe a
     currentTransState = return ()
     restoreTransState Nothing = mzero
     restoreTransState (Just a) = return a
@@ -179,7 +179,7 @@ 
 instance RunnableTrans ListT where
      type TransformerState ListT m = ()
-     type TransformerResult ListT m a = [a]
+     type TransformerResult ListT a = [a]
      currentTransState = return ()
      restoreTransState = fromFoldable
      runTransformer m _ = toList m

@@ -12,6 +12,7 @@ import Control.Effects.Async
 import Control.Effects.List
 import Control.Effects.Yield
+import Control.Effects.Resource
 import Control.Concurrent hiding (yield)
 import System.IO
 
@@ -123,4 +124,9 @@     await <- implementYieldViaMVar @Int yieldTest
     traverseYielded_ await $ \res -> do
         print res
-        void getLine+        void getLine
+
+testResource = evaluateAll $ bracket
+    (choose [True, False] >>= \tf -> liftIO (putStrLn ("acq " ++ show tf)) >> return tf)
+    (\tf _ -> liftIO $ putStrLn ("cleaning " ++ show tf))
+    (\tf -> if tf then liftIO $ putStrLn "true" else error "io err" >> liftIO (putStrLn "false") )