diff --git a/README.md b/README.md --- a/README.md +++ b/README.md @@ -1,7 +1,5 @@ # little-rio -[![CircleCI](https://circleci.com/gh/ejconlon/little-rio/tree/master.svg?style=svg)](https://circleci.com/gh/ejconlon/little-rio/tree/master) - When you need just the `RIO` monad (but you want a `MonadCatch` instance and some other orphans) -This is derived from the `rio` library ([LICENSE](https://hackage.haskell.org/package/rio-0.1.18.0/src/LICENSE)) and the `rio-orphans` library ([LICENSE](https://hackage.haskell.org/package/rio-orphans-0.1.1.0/src/LICENSE)) +This is derived from the `rio` library ([LICENSE](https://hackage.haskell.org/package/rio-0.1.22.0/src/LICENSE)) and the `rio-orphans` library ([LICENSE](https://hackage.haskell.org/package/rio-orphans-0.1.2.0/src/LICENSE)) diff --git a/Setup.hs b/Setup.hs deleted file mode 100644 --- a/Setup.hs +++ /dev/null @@ -1,2 +0,0 @@ -import Distribution.Simple -main = defaultMain diff --git a/little-rio.cabal b/little-rio.cabal --- a/little-rio.cabal +++ b/little-rio.cabal @@ -1,13 +1,13 @@ cabal-version: 1.12 --- This file has been generated from package.yaml by hpack version 0.34.4. +-- This file has been generated from package.yaml by hpack version 0.35.1. -- -- see: https://github.com/sol/hpack -- --- hash: f81c4dd488c8eaba076b9bf8159a26d56663eea5a73b615126571edd541b1fb4 +-- hash: 5a57c092ba5bccf9876a634d97b3f2048b4ba5261a47f906c61090dd84c6e66c name: little-rio -version: 1.0.1 +version: 2.0.0 synopsis: When you need just the RIO monad description: Please see the README on GitHub at category: Control @@ -45,11 +45,9 @@ ghc-options: -Wall -Wcompat -Widentities -Wincomplete-record-updates -Wincomplete-uni-patterns -Wpartial-fields -Wredundant-constraints -fno-warn-unused-top-binds build-depends: base >=4.12 && <5 - , deepseq >=1.4.4.0 && <2 , exceptions >=0.10 && <1 , little-logger >=1.0.1 && <1.1 , microlens >=0.4 && <1 - , microlens-mtl >=0.2 && <1 , mtl >=2.2 && <3 , primitive >=0.7.0.1 && <1 , resourcet >=1.2.4.2 && <2 diff --git a/src/LittleRIO.hs b/src/LittleRIO.hs --- a/src/LittleRIO.hs +++ b/src/LittleRIO.hs @@ -1,62 +1,57 @@ -{-# LANGUAGE DeriveAnyClass #-} {-# LANGUAGE UndecidableInstances #-} -{- | -Most definitions follow the RIO lib: https://hackage.haskell.org/package/rio-0.1.18.0/docs/RIO.html -The rest follow from orphans: https://hackage.haskell.org/package/rio-orphans-0.1.1.0/docs/src/RIO.Orphans.html -See LICENSE info in the README. --} +-- | +-- Most definitions follow the RIO lib: https://hackage.haskell.org/package/rio-0.1.22.0/docs/RIO.html +-- The rest follow from orphans: https://hackage.haskell.org/package/rio-orphans-0.1.2.0/docs/RIO-Orphans.html +-- See LICENSE info in the README. module LittleRIO - ( HasResourceMap (..) - , HasStateRef (..) - , HasWriteRef (..) - , SimpleResourceEnv (..) - , SimpleStateEnv (..) - , SimpleWriteEnv (..) - , SomeRef (..) - , ResourceMap - , RIO (..) - , getStateRef - , liftRIO - , listenWriteRef - , newSomeRef + ( RIO (..) , mapRIO - , modifySomeRef - , modifyStateRef - , passWriteRef - , putStateRef - , runSimpleResourceRIO - , runSimpleStateRIO - , runSimpleWriteRIO + , liftRIO + , unliftRIO , runRIO + , SomeRef (..) , readSomeRef - , resourceRIO - , tellWriteRef - , unliftRIO - , withResourceMap , writeSomeRef - ) where + , modifySomeRef + , newSomeRef + , HasStateRef (..) + , HasWriteRef (..) + , ResourceMap + , HasResourceMap (..) + , withResourceMap + ) +where import Control.Applicative (liftA2) -import Control.DeepSeq (NFData (..)) import Control.Monad.Catch (MonadCatch, MonadMask, MonadThrow) import Control.Monad.IO.Class (MonadIO (..)) import Control.Monad.IO.Unlift (MonadUnliftIO (..), UnliftIO, askUnliftIO) import Control.Monad.Primitive (PrimMonad (..)) -import Control.Monad.Reader (MonadReader (..), ReaderT (..)) +import Control.Monad.Reader (MonadReader (..), ReaderT (..), asks) import Control.Monad.State (MonadState (..)) -import Control.Monad.Trans.Resource (runResourceT) -import Control.Monad.Trans.Resource.Internal (MonadResource (..), ReleaseMap, ResourceT (..)) +import Control.Monad.Trans.Resource (InternalState, MonadResource (..), ResourceT, runResourceT, withInternalState) +import Control.Monad.Trans.Resource.Internal (unResourceT) import Control.Monad.Writer (MonadWriter (..)) import Data.IORef (IORef, newIORef, readIORef, writeIORef) -import GHC.Generics (Generic) -import Lens.Micro (Lens', lens) -import Lens.Micro.Mtl (view) +import Lens.Micro (Lens') +import Lens.Micro.Extras (view) import LittleLogger (LogActionWrapperM (..), MonadLogger) -newtype RIO env a = RIO { unRIO :: ReaderT env IO a } - deriving newtype (Functor, Applicative, Monad, MonadReader env, MonadIO, MonadThrow, MonadFail, MonadCatch, MonadMask, MonadUnliftIO) - deriving MonadLogger via LogActionWrapperM env (RIO env) +newtype RIO env a = RIO {unRIO :: ReaderT env IO a} + deriving newtype + ( Functor + , Applicative + , Monad + , MonadReader env + , MonadIO + , MonadThrow + , MonadFail + , MonadCatch + , MonadMask + , MonadUnliftIO + ) + deriving (MonadLogger) via LogActionWrapperM env (RIO env) instance Semigroup a => Semigroup (RIO env a) where (<>) = liftA2 (<>) @@ -88,9 +83,6 @@ data SomeRef a = SomeRef !(IO a) !(a -> IO ()) -instance NFData (SomeRef a) where - rnf (SomeRef r w) = seq r (seq w ()) - readSomeRef :: MonadIO m => SomeRef a -> m a readSomeRef (SomeRef x _) = liftIO x @@ -112,35 +104,19 @@ instance HasStateRef a (SomeRef a) where stateRefL = id -data SimpleStateEnv st env = SimpleStateEnv - { sseRef :: !(SomeRef st) - , sseEnv :: !env - } deriving stock (Functor, Foldable, Traversable, Generic) - deriving anyclass (NFData) - -instance HasStateRef st (SimpleStateEnv st env) where - stateRefL = lens sseRef (\(SimpleStateEnv _ env) st -> SimpleStateEnv st env) - -runSimpleStateRIO :: MonadIO m => st -> env -> RIO (SimpleStateEnv st env) a -> m (a, st) -runSimpleStateRIO st env m = do - ref <- newSomeRef st - a <- runRIO (SimpleStateEnv ref env) m - st' <- readSomeRef ref - pure (a, st') - getStateRef :: (HasStateRef st env, MonadReader env m, MonadIO m) => m st getStateRef = do - ref <- view stateRefL + ref <- asks (view stateRefL) liftIO (readSomeRef ref) putStateRef :: (HasStateRef st env, MonadReader env m, MonadIO m) => st -> m () putStateRef st = do - ref <- view stateRefL + ref <- asks (view stateRefL) liftIO (writeSomeRef ref st) modifyStateRef :: (HasStateRef st env, MonadReader env m, MonadIO m) => (st -> st) -> m () modifyStateRef f = do - ref <- view stateRefL + ref <- asks (view stateRefL) liftIO (modifySomeRef ref f) instance HasStateRef st env => MonadState st (RIO env) where @@ -153,43 +129,27 @@ instance HasWriteRef a (SomeRef a) where writeRefL = id -data SimpleWriteEnv w env = SimpleWriteEnv - { sweRef :: !(SomeRef w) - , sweEnv :: !env - } deriving stock (Functor, Foldable, Traversable, Generic) - deriving anyclass (NFData) - -instance HasWriteRef w (SimpleWriteEnv w env) where - writeRefL = lens sweRef (\(SimpleWriteEnv _ env) w -> SimpleWriteEnv w env) - -runSimpleWriteRIO :: (MonadIO m, Monoid w) => env -> RIO (SimpleWriteEnv w env) a -> m (a, w) -runSimpleWriteRIO env m = do - ref <- newSomeRef mempty - a <- runRIO (SimpleWriteEnv ref env) m - w <- readSomeRef ref - pure (a, w) - tellWriteRef :: (HasWriteRef w env, MonadReader env m, MonadIO m, Semigroup w) => w -> m () tellWriteRef value = do - ref <- view writeRefL - liftIO $ modifySomeRef ref (<> value) + ref <- asks (view writeRefL) + liftIO (modifySomeRef ref (<> value)) listenWriteRef :: (HasWriteRef w env, MonadReader env m, MonadIO m) => m a -> m (a, w) listenWriteRef action = do - w1 <- view writeRefL >>= liftIO . readSomeRef + w1 <- asks (view writeRefL) >>= liftIO . readSomeRef a <- action w2 <- do - refEnv <- view writeRefL - v <- liftIO $ readSomeRef refEnv - _ <- liftIO $ writeSomeRef refEnv w1 + refEnv <- asks (view writeRefL) + v <- liftIO (readSomeRef refEnv) + _ <- liftIO (writeSomeRef refEnv w1) return v return (a, w2) passWriteRef :: (HasWriteRef w env, MonadReader env m, MonadIO m) => m (a, w -> w) -> m a passWriteRef action = do (a, transF) <- action - ref <- view writeRefL - liftIO $ modifySomeRef ref transF + ref <- asks (view writeRefL) + liftIO (modifySomeRef ref transF) return a instance (Monoid w, HasWriteRef w env) => MonadWriter w (RIO env) where @@ -197,32 +157,21 @@ listen = listenWriteRef pass = passWriteRef -type ResourceMap = IORef ReleaseMap +type ResourceMap = InternalState withResourceMap :: MonadUnliftIO m => (ResourceMap -> m a) -> m a -withResourceMap inner = - withRunInIO (\run -> runResourceT (ResourceT (run . inner))) +withResourceMap inner = runResourceT (withInternalState inner) +-- withRunInIO (\run -> runResourceT (ResourceT (run . inner))) + class HasResourceMap env where resourceMapL :: Lens' env ResourceMap -instance HasResourceMap (IORef ReleaseMap) where +instance HasResourceMap ResourceMap where resourceMapL = id -data SimpleResourceEnv env = SimpleResourceEnv - { sreMap :: !ResourceMap - , sreEnv :: !env - } deriving stock (Functor, Foldable, Traversable, Generic) - deriving anyclass (NFData) - -instance HasResourceMap (SimpleResourceEnv env) where - resourceMapL = lens sreMap (\(SimpleResourceEnv _ env) m -> SimpleResourceEnv m env) - -runSimpleResourceRIO :: MonadUnliftIO m => env -> RIO (SimpleResourceEnv env) a -> m a -runSimpleResourceRIO env m = withResourceMap (\rm -> runRIO (SimpleResourceEnv rm env) m) - resourceRIO :: HasResourceMap env => ResourceT IO a -> RIO env a -resourceRIO (ResourceT f) = view resourceMapL >>= liftIO . f +resourceRIO m = asks (view resourceMapL) >>= liftIO . unResourceT m instance HasResourceMap env => MonadResource (RIO env) where liftResourceT = resourceRIO