diff --git a/ChangeLog.md b/ChangeLog.md --- a/ChangeLog.md +++ b/ChangeLog.md @@ -1,5 +1,11 @@ # Changelog for rio +## 0.1.4.0 + +* Add `Const` and `Identity` +* Add `Reader` and `runReader` +* Add instances for `MonadWriter` and `MonadState` to `RIO` via mutable reference [#103](https://github.com/commercialhaskell/rio/issues/103) + ## 0.1.3.0 * Add `newLogFunc` function to create `LogFunc` records outside of a callback scope diff --git a/rio.cabal b/rio.cabal --- a/rio.cabal +++ b/rio.cabal @@ -2,10 +2,10 @@ -- -- see: https://github.com/sol/hpack -- --- hash: 09edf1a8b8f03bf2d61519411bfb56b861ab82c696bf58407444fcb13d0c4e04 +-- hash: 11d51864811c17133c8f1aecfbec3086de7f37c755fad2fb3e2c54ed8b85f817 name: rio -version: 0.1.3.0 +version: 0.1.4.0 synopsis: A standard library for Haskell description: See README and Haddocks at category: Control @@ -50,6 +50,7 @@ RIO.Set RIO.Set.Partial RIO.Set.Unchecked + RIO.State RIO.Text RIO.Text.Lazy RIO.Text.Lazy.Partial @@ -67,6 +68,7 @@ RIO.Vector.Unboxed.Partial RIO.Vector.Unboxed.Unsafe RIO.Vector.Unsafe + RIO.Writer other-modules: RIO.Prelude.Display RIO.Prelude.Extra @@ -117,6 +119,7 @@ RIO.LoggerSpec RIO.Prelude.ExtraSpec RIO.Prelude.IOSpec + RIO.Prelude.RIOSpec RIO.Prelude.SimpleSpec RIO.PreludeSpec RIO.TextSpec diff --git a/src/RIO/Prelude/RIO.hs b/src/RIO/Prelude/RIO.hs --- a/src/RIO/Prelude/RIO.hs +++ b/src/RIO/Prelude/RIO.hs @@ -1,12 +1,31 @@ +{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE GeneralizedNewtypeDeriving #-} {-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE FunctionalDependencies #-} +{-# LANGUAGE UndecidableInstances #-} module RIO.Prelude.RIO ( RIO (..) , runRIO , liftRIO + -- * SomeRef for Writer/State interfaces + , SomeRef + , HasStateRef (..) + , HasWriteRef (..) + , newSomeRef + , newUnboxedSomeRef + , readSomeRef + , writeSomeRef + , modifySomeRef ) where +import GHC.Exts (RealWorld) + +import RIO.Prelude.Lens +import RIO.Prelude.URef import RIO.Prelude.Reexports +import Control.Monad.State (MonadState(..)) +import Control.Monad.Writer (MonadWriter(..)) -- | The Reader+IO monad. This is different from a 'ReaderT' because: -- @@ -35,3 +54,105 @@ instance PrimMonad (RIO env) where type PrimState (RIO env) = PrimState IO primitive = RIO . ReaderT . const . primitive + +-- | Abstraction over how to read from and write to a mutable reference +-- +-- @since 0.1.4.0 +data SomeRef a + = SomeRef !(IO a) !(a -> IO ()) + +-- | Read from a SomeRef +-- +-- @since 0.1.4.0 +readSomeRef :: MonadIO m => SomeRef a -> m a +readSomeRef (SomeRef x _) = liftIO x + +-- | Write to a SomeRef +-- +-- @since 0.1.4.0 +writeSomeRef :: MonadIO m => SomeRef a -> a -> m () +writeSomeRef (SomeRef _ x) = liftIO . x + +-- | Modify a SomeRef +-- This function is subject to change due to the lack of atomic operations +-- +-- @since 0.1.4.0 +modifySomeRef :: MonadIO m => SomeRef a -> (a -> a) -> m () +modifySomeRef (SomeRef read write) f = + liftIO $ (f <$> read) >>= write + +ioRefToSomeRef :: IORef a -> SomeRef a +ioRefToSomeRef ref = do + SomeRef (readIORef ref) + (\val -> modifyIORef' ref (\_ -> val)) + +uRefToSomeRef :: Unbox a => URef RealWorld a -> SomeRef a +uRefToSomeRef ref = do + SomeRef (readURef ref) (writeURef ref) + +-- | Environment values with stateful capabilities to SomeRef +-- +-- @since 0.1.4.0 +class HasStateRef s env | env -> s where + stateRefL :: Lens' env (SomeRef s) + +-- | Identity state reference where the SomeRef is the env +-- +-- @since 0.1.4.0 +instance HasStateRef a (SomeRef a) where + stateRefL = lens id (\_ x -> x) + +-- | Environment values with writing capabilities to SomeRef +-- +-- @since 0.1.4.0 +class HasWriteRef w env | env -> w where + writeRefL :: Lens' env (SomeRef w) + +-- | Identity write reference where the SomeRef is the env +-- +-- @since 0.1.4.0 +instance HasWriteRef a (SomeRef a) where + writeRefL = lens id (\_ x -> x) + +instance HasStateRef s env => MonadState s (RIO env) where + get = do + ref <- view stateRefL + liftIO $ readSomeRef ref + put st = do + ref <- view stateRefL + liftIO $ writeSomeRef ref st + +instance (Monoid w, HasWriteRef w env) => MonadWriter w (RIO env) where + tell value = do + ref <- view writeRefL + liftIO $ modifySomeRef ref (`mappend` value) + + listen action = do + w1 <- view writeRefL >>= liftIO . readSomeRef + a <- action + w2 <- do + refEnv <- view writeRefL + v <- liftIO $ readSomeRef refEnv + _ <- liftIO $ writeSomeRef refEnv w1 + return v + return (a, w2) + + pass action = do + (a, transF) <- action + ref <- view writeRefL + liftIO $ modifySomeRef ref transF + return a + +-- | create a new boxed SomeRef +-- +-- @since 0.1.4.0 +newSomeRef :: MonadIO m => a -> m (SomeRef a) +newSomeRef a = do + ioRefToSomeRef <$> newIORef a + +-- | create a new unboxed SomeRef +-- +-- @since 0.1.4.0 +newUnboxedSomeRef :: (MonadIO m, Unbox a) => a -> m (SomeRef a) +newUnboxedSomeRef a = + uRefToSomeRef <$> (liftIO $ newURef a) diff --git a/src/RIO/Prelude/Reexports.hs b/src/RIO/Prelude/Reexports.hs --- a/src/RIO/Prelude/Reexports.hs +++ b/src/RIO/Prelude/Reexports.hs @@ -49,10 +49,12 @@ , Control.Monad.Catch.MonadThrow(..) , Control.Monad.Reader.MonadReader , Control.Monad.Reader.MonadTrans(..) + , Control.Monad.Reader.Reader , Control.Monad.Reader.ReaderT(..) , Control.Monad.Reader.ask , Control.Monad.Reader.asks , Control.Monad.Reader.local + , Control.Monad.Reader.runReader , Data.Bool.Bool(..) , Data.Bool.bool , Data.Bool.not @@ -112,6 +114,8 @@ , Data.Functor.void , (Data.Functor.$>) , (Data.Functor.<$>) + , Data.Functor.Const.Const(..) + , Data.Functor.Identity.Identity(..) , Data.Hashable.Hashable , Data.HashMap.Strict.HashMap , Data.HashSet.HashSet @@ -230,6 +234,8 @@ import Control.Monad.Catch (MonadThrow) import Control.Monad.Primitive (PrimMonad (..)) import Control.Monad.Reader (MonadReader, ReaderT (..), ask, asks) +import Control.Monad.State (MonadState(..)) +import Control.Monad.Writer (MonadWriter (..)) import Data.Bool (otherwise) import Data.ByteString (ByteString) import Data.ByteString.Builder (Builder) @@ -273,6 +279,8 @@ import qualified Data.Foldable import qualified Data.Function import qualified Data.Functor +import qualified Data.Functor.Const +import qualified Data.Functor.Identity import qualified Data.Hashable import qualified Data.HashMap.Strict import qualified Data.HashSet diff --git a/src/RIO/State.hs b/src/RIO/State.hs new file mode 100644 --- /dev/null +++ b/src/RIO/State.hs @@ -0,0 +1,9 @@ +-- | Provides reexports of 'MonadState' and related helpers. +-- +-- @since 0.1.4.0 +module RIO.State + ( + Control.Monad.State.MonadState (..) + ) where + +import qualified Control.Monad.State diff --git a/src/RIO/Writer.hs b/src/RIO/Writer.hs new file mode 100644 --- /dev/null +++ b/src/RIO/Writer.hs @@ -0,0 +1,9 @@ +-- | Provides reexports of 'MonadWriter' and related helpers. +-- +-- @since 0.1.4.0 +module RIO.Writer + ( + Control.Monad.Writer.MonadWriter (..) + ) where + +import qualified Control.Monad.Writer diff --git a/test/RIO/Prelude/RIOSpec.hs b/test/RIO/Prelude/RIOSpec.hs new file mode 100644 --- /dev/null +++ b/test/RIO/Prelude/RIOSpec.hs @@ -0,0 +1,54 @@ +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE NoImplicitPrelude #-} +{-# LANGUAGE ViewPatterns #-} +module RIO.Prelude.RIOSpec (spec) where + +import RIO +import RIO.State +import RIO.Writer +import Test.Hspec +import Test.Hspec.QuickCheck + +spec = do + describe "RIO writer instance" $ do + it "tell works" $ do + ref <- newSomeRef (mempty :: Text) + runRIO ref $ do + tell "hello\n" + tell "world\n" + contents <- readSomeRef ref + contents `shouldBe` "hello\nworld\n" + + it "listen works" $ do + ref <- newSomeRef (mempty :: Text) + ((), str) <- runRIO ref $ listen $ do + tell "hello\n" + tell "world\n" + contents <- readSomeRef ref + contents `shouldBe` "" + str `shouldBe` "hello\nworld\n" + + it "pass works" $ do + ref <- newSomeRef (mempty :: Text) + result <- runRIO ref $ pass $ do + tell "hello\n" + tell "world\n" + return ((), \a -> a <> "!") + contents <- readSomeRef ref + contents `shouldBe` "hello\nworld\n!" + + describe "RIO state instance" $ do + it "get works" $ do + ref <- newSomeRef (mempty :: Text) + result <- runRIO ref $ do + put "hello world" + x <- get + return x + result `shouldBe` "hello world" + + it "state works" $ do + ref <- newSomeRef (mempty :: Text) + newRef <- newSomeRef ("Hello World!" :: Text) + result <- runRIO ref $ state (\ref -> ((), "Hello World!")) + contents <- readSomeRef ref + contents `shouldBe` "Hello World!"