diff --git a/benign.cabal b/benign.cabal index 32a23f4..0b09dd7 100644 --- a/benign.cabal +++ b/benign.cabal @@ -35,6 +35,7 @@ library , deepseq , stm , strict-wrapper + , transformers default-language: Haskell2010 executable simple-print @@ -50,4 +51,5 @@ executable simple-print , deepseq , stm , strict-wrapper + , transformers default-language: Haskell2010 diff --git a/package.yaml b/package.yaml index 7ee4d79..fe399ef 100644 --- a/package.yaml +++ b/package.yaml @@ -14,6 +14,7 @@ dependencies: - deepseq - stm - strict-wrapper + - transformers ghc-options: -Wall -Wcompat -Wincomplete-record-updates -Wincomplete-uni-patterns -Wnoncanonical-monad-instances -Wredundant-constraints diff --git a/src/Benign.hs b/src/Benign.hs index 2e69e9a..fdd8d1f 100644 --- a/src/Benign.hs +++ b/src/Benign.hs @@ -43,6 +43,10 @@ module Benign NF (..), EvalIO (..), PureEval (..), + + -- * Monads + EvalM (..), + withSettingM, ) where @@ -51,6 +55,10 @@ import Control.Concurrent.Async (async) import Control.Concurrent.Async qualified as Async import Control.DeepSeq import Control.Exception (bracket_, evaluate, finally) +import Control.Monad.Trans.Reader +import Control.Monad.Trans.State.Lazy +import Data.Coerce +import Data.Functor.Identity import Data.Int import Data.Map.Strict (Map) import Data.Map.Strict qualified as Map @@ -239,6 +247,12 @@ class Eval a where extractEval :: Thunk a -> Result a +instance (Eval a, Eval b) => Eval (a, b) where + data Thunk (a, b) = PairThunk (Thunk a) (Thunk b) + type Result (a, b) = (Result a, Result b) + eval (a, b) = PairThunk (eval a) (eval b) + extractEval (PairThunk a b) = (extractEval a, extractEval b) + -- | Evaluation strategy: evaluates `a` by simply calling `seq` on it. newtype Seq a = Seq a deriving anyclass (EvalIO) @@ -335,3 +349,45 @@ newtype PureEval a = PureEval a instance Eval a => EvalIO (PureEval a) where type ResultIO (PureEval a) = Result a evalIO (PureEval a) = evalInIO a + +--------------------------------------------------------------------------- +-- +-- Evaluate in a monad +-- +--------------------------------------------------------------------------- + +-- | In non-IO monadic code (that is when monads are used as a way to organise +-- pure code), naturally, we'll be wanting to use benign effect as well. How +-- scopes and running monadic code interleave doesn't have a generic +-- answer. This is because monadic code is fundamentally staged: first you build +-- a monadic expression, then it is run. Benign effects, and in particular +-- local state updates, must happen when the monad is run, not when the +-- expression is built. +-- +-- Just like there isn't a generic `run` function, since all monads interpret +-- the monadic expression differently, each monad needs to explain how they +-- implement 'withAltering' and 'unsafeSpanBenign'. This is what the (admittedly +-- poorly named) 'EvalM' class lets monad do. +class EvalM m where + withAlteringM :: Eval b => Field a -> (Maybe a -> Maybe a) -> m b -> m (Result b) + unsafeSpanBenignM :: Eval a => IO () -> IO () -> m a -> m (Result a) + +withSettingM :: (EvalM m, Eval b) => Field a -> a -> m b -> m (Result b) +withSettingM f a = withAlteringM f (\_ -> Just a) + +instance EvalM Identity where + withAlteringM :: forall b a. Eval b => Field a -> (Maybe a -> Maybe a) -> Identity b -> Identity (Result b) + withAlteringM = coerce $ withAltering @b @a + unsafeSpanBenignM :: forall a. Eval a => IO () -> IO () -> Identity a -> Identity (Result a) + unsafeSpanBenignM = coerce $ unsafeSpanBenign @a + +instance (EvalM m, Eval s, Result s ~ s) => EvalM (StateT s m) where + withAlteringM f g (StateT thing) = StateT $ \s -> withAlteringM f g (thing s) + + unsafeSpanBenignM :: (EvalM m, Eval s, Result s ~ s, Eval a) => IO () -> IO () -> StateT s m a -> StateT s m (Result a) + unsafeSpanBenignM before after (StateT thing) = StateT $ \s -> unsafeSpanBenignM before after (thing s) + +instance (EvalM m) => EvalM (ReaderT e m) where + withAlteringM f g (ReaderT thing) = ReaderT $ \e -> withAlteringM f g (thing e) + + unsafeSpanBenignM before after (ReaderT thing) = ReaderT $ \e -> unsafeSpanBenignM before after (thing e)