diff --git a/acquire.cabal b/acquire.cabal --- a/acquire.cabal +++ b/acquire.cabal @@ -1,7 +1,7 @@ name: acquire version: - 0.2.0.1 + 0.3 synopsis: Abstraction over management of resources description: @@ -16,7 +16,7 @@ author: Nikita Volkov maintainer: - Metrix.AI Ninjas + Metrix.AI Tech Team copyright: (c) 2013 Gabriel Gonzalez, 2018 Metrix.AI license: @@ -42,9 +42,9 @@ default-language: Haskell2010 exposed-modules: - Acquire.Acquire - Acquire.IO + Acquire other-modules: Acquire.Prelude build-depends: - base >=4.7 && <5 + base >=4.9 && <5, + transformers >=0.5 && <0.6 diff --git a/library/Acquire.hs b/library/Acquire.hs new file mode 100644 --- /dev/null +++ b/library/Acquire.hs @@ -0,0 +1,90 @@ +module Acquire +where + +import Acquire.Prelude + + +-- * IO +------------------------- + +{-| +Execute an action, which uses a resource, +having a resource provider. +-} +acquireAndUse :: Acquire env -> Use env err res -> IO (Either err res) +acquireAndUse (Acquire acquireIo) (Use useRdr) = + bracket acquireIo snd (runExceptT . runReaderT useRdr . fst) + + +-- * Acquire +------------------------- + +{-| +Resource provider. +Abstracts over resource acquisition and releasing. + +Composes well, allowing you to merge multiple providers into one. + +Implementation of http://www.haskellforall.com/2013/06/the-resource-applicative.html +-} +newtype Acquire resource = + Acquire (IO (resource, IO ())) + +instance Functor Acquire where + fmap f (Acquire io) = + Acquire $ do + (resource, release) <- io + return (f resource, release) + +instance Applicative Acquire where + pure resource = + Acquire (pure (resource, pure ())) + Acquire io1 <*> Acquire io2 = + Acquire $ do + (f, release1) <- io1 + (x, release2) <- onException io2 release1 + return (f x, release2 >> release1) + +instance Monad Acquire where + return = pure + (>>=) (Acquire io1) k2 = + Acquire $ do + (resource1, release1) <- io1 + (resource2, release2) <- case k2 resource1 of Acquire io2 -> onException io2 release1 + return (resource2, release2 >> release1) + +instance MonadIO Acquire where + liftIO io = + Acquire (fmap (, return ()) io) + + +-- * Use +------------------------- + +{-| +Resource handler, which has a notion of pure errors. +-} +newtype Use env err res = Use (ReaderT env (ExceptT err IO) res) + deriving (Functor, Applicative, Alternative, Monad, MonadPlus) + +instance Bifunctor (Use env) where + first = mapErr + second = fmap + +{-| +Map the environment of a resource handler. +-} +mapEnv :: (b -> a) -> Use a err res -> Use b err res +mapEnv fn (Use rdr) = Use (withReaderT fn rdr) + +{-| +Map the error of a resource handler. +-} +mapErr :: (a -> b) -> Use env a res -> Use env b res +mapErr fn (Use rdr) = Use (mapReaderT (withExceptT fn) rdr) + +{-| +Map both the environment and the error of a resource handler. +-} +mapEnvAndErr :: (envB -> envA) -> (errA -> errB) -> Use envA errA res -> Use envB errB res +mapEnvAndErr envProj errProj (Use rdr) = Use (withReaderT envProj (mapReaderT (withExceptT errProj) rdr)) diff --git a/library/Acquire/Acquire.hs b/library/Acquire/Acquire.hs deleted file mode 100644 --- a/library/Acquire/Acquire.hs +++ /dev/null @@ -1,38 +0,0 @@ -module Acquire.Acquire -where - -import Acquire.Prelude - - -{-| -Implementation of http://www.haskellforall.com/2013/06/the-resource-applicative.html --} -newtype Acquire resource = - Acquire (IO (resource, IO ())) - -instance Functor Acquire where - fmap f (Acquire io) = - Acquire $ do - (resource, release) <- io - return (f resource, release) - -instance Applicative Acquire where - pure resource = - Acquire (pure (resource, pure ())) - Acquire io1 <*> Acquire io2 = - Acquire $ do - (f, release1) <- io1 - (x, release2) <- onException io2 release1 - return (f x, release2 >> release1) - -instance Monad Acquire where - return = pure - (>>=) (Acquire io1) k2 = - Acquire $ do - (resource1, release1) <- io1 - (resource2, release2) <- case k2 resource1 of Acquire io2 -> onException io2 release1 - return (resource2, release2 >> release1) - -instance MonadIO Acquire where - liftIO io = - Acquire (fmap (, return ()) io) diff --git a/library/Acquire/IO.hs b/library/Acquire/IO.hs deleted file mode 100644 --- a/library/Acquire/IO.hs +++ /dev/null @@ -1,11 +0,0 @@ -module Acquire.IO -where - -import Acquire.Prelude -import Acquire.Acquire - - -acquire :: Acquire resource -> (resource -> IO a) -> IO a -acquire (Acquire io) handle = - bracket io snd (handle . fst) - diff --git a/library/Acquire/Prelude.hs b/library/Acquire/Prelude.hs --- a/library/Acquire/Prelude.hs +++ b/library/Acquire/Prelude.hs @@ -7,7 +7,7 @@ -- base ------------------------- import Control.Applicative as Exports -import Control.Arrow as Exports +import Control.Arrow as Exports hiding (first, second) import Control.Category as Exports import Control.Concurrent as Exports import Control.Exception as Exports @@ -15,6 +15,7 @@ import Control.Monad.IO.Class as Exports import Control.Monad.Fix as Exports hiding (fix) import Control.Monad.ST as Exports +import Data.Bifunctor as Exports import Data.Bits as Exports import Data.Bool as Exports import Data.Char as Exports @@ -67,3 +68,14 @@ import Text.Printf as Exports (printf, hPrintf) import Text.Read as Exports (Read(..), readMaybe, readEither) import Unsafe.Coerce as Exports + +-- transformers +------------------------- +import Control.Monad.IO.Class as Exports +import Control.Monad.Trans.Class as Exports +import Control.Monad.Trans.Cont as Exports hiding (shift, callCC) +import Control.Monad.Trans.Except as Exports (ExceptT(ExceptT), Except, except, runExcept, runExceptT, mapExcept, mapExceptT, withExcept, withExceptT) +import Control.Monad.Trans.Maybe as Exports +import Control.Monad.Trans.Reader as Exports (Reader, runReader, mapReader, withReader, ReaderT(ReaderT), runReaderT, mapReaderT, withReaderT) +import Control.Monad.Trans.State.Strict as Exports (State, runState, evalState, execState, mapState, withState, StateT(StateT), runStateT, evalStateT, execStateT, mapStateT, withStateT) +import Control.Monad.Trans.Writer.Strict as Exports (Writer, runWriter, execWriter, mapWriter, WriterT(..), execWriterT, mapWriterT)