little-rio 1.0.1 → 3.0.0
raw patch · 4 files changed
Files
- README.md +1/−3
- Setup.hs +0/−2
- little-rio.cabal +5/−7
- src/LittleRIO.hs +65/−120
README.md view
@@ -1,7 +1,5 @@ # little-rio -[](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))
− Setup.hs
@@ -1,2 +0,0 @@-import Distribution.Simple-main = defaultMain
little-rio.cabal view
@@ -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.37.0. -- -- see: https://github.com/sol/hpack ----- hash: f81c4dd488c8eaba076b9bf8159a26d56663eea5a73b615126571edd541b1fb4+-- hash: 2c34a0cd81d30bbaa6fe452cd9718b33a590ce2ffd05268cfab6f60d7989b54a name: little-rio-version: 1.0.1+version: 3.0.0 synopsis: When you need just the RIO monad description: Please see the README on GitHub at <https://github.com/ejconlon/little-rio#readme> category: Control@@ -45,12 +45,10 @@ 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+ , little-logger >=3.0 && <4 , mtl >=2.2 && <3+ , optics >=0.4 && <1 , primitive >=0.7.0.1 && <1 , resourcet >=1.2.4.2 && <2 , unliftio-core >=0.1 && <1
src/LittleRIO.hs view
@@ -1,67 +1,60 @@-{-# 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 LittleLogger (LogActionWrapperM (..), MonadLogger)+import Optics (Lens', equality', view) -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+instance (Semigroup a) => Semigroup (RIO env a) where (<>) = liftA2 (<>) -instance Monoid a => Monoid (RIO env a) where+instance (Monoid a) => Monoid (RIO env a) where mempty = pure mempty mappend = (<>) @@ -80,70 +73,51 @@ env <- ask runRIO env m -unliftRIO :: MonadIO m => env -> m (UnliftIO (RIO env))+unliftRIO :: (MonadIO m) => env -> m (UnliftIO (RIO env)) unliftRIO env = liftIO (runRIO env askUnliftIO) -runRIO :: MonadIO m => env -> RIO env a -> m a+runRIO :: (MonadIO m) => env -> RIO env a -> m a runRIO r m = liftIO (runReaderT (unRIO m) r) 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 :: (MonadIO m) => SomeRef a -> m a readSomeRef (SomeRef x _) = liftIO x -writeSomeRef :: MonadIO m => SomeRef a -> a -> m ()+writeSomeRef :: (MonadIO m) => SomeRef a -> a -> m () writeSomeRef (SomeRef _ x) = liftIO . x -modifySomeRef :: MonadIO m => SomeRef a -> (a -> a) -> m ()+modifySomeRef :: (MonadIO m) => SomeRef a -> (a -> a) -> m () modifySomeRef (SomeRef read' write) f = liftIO (read' >>= write . f) ioRefToSomeRef :: IORef a -> SomeRef a ioRefToSomeRef ref = SomeRef (readIORef ref) (writeIORef ref) -newSomeRef :: MonadIO m => a -> m (SomeRef a)+newSomeRef :: (MonadIO m) => a -> m (SomeRef a) newSomeRef = liftIO . fmap ioRefToSomeRef . newIORef class HasStateRef st env | env -> st where stateRefL :: Lens' env (SomeRef st) 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')+ stateRefL = equality' 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+instance (HasStateRef st env) => MonadState st (RIO env) where get = getStateRef put = putStateRef @@ -151,45 +125,29 @@ writeRefL :: Lens' env (SomeRef w) 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)+ writeRefL = equality' 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 +155,19 @@ 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 :: (MonadUnliftIO m) => (ResourceMap -> m a) -> m a+withResourceMap inner = runResourceT (withInternalState inner) class HasResourceMap env where resourceMapL :: Lens' env ResourceMap -instance HasResourceMap (IORef ReleaseMap) 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)+instance HasResourceMap ResourceMap where+ resourceMapL = equality' -resourceRIO :: HasResourceMap env => ResourceT IO a -> RIO env a-resourceRIO (ResourceT f) = view resourceMapL >>= liftIO . f+resourceRIO :: (HasResourceMap env) => ResourceT IO a -> RIO env a+resourceRIO m = asks (view resourceMapL) >>= liftIO . unResourceT m -instance HasResourceMap env => MonadResource (RIO env) where+instance (HasResourceMap env) => MonadResource (RIO env) where liftResourceT = resourceRIO