diff --git a/CHANGELOG.md b/CHANGELOG.md --- a/CHANGELOG.md +++ b/CHANGELOG.md @@ -1,5 +1,16 @@ # Changelog for `cleff` +## 0.2.1.0 (2022-02-13) + +### Added + +- Lifted convenience instances of `Bounded`, `Num`, `Fractional`, `Floating` and `IsString` for `Eff` +- `MonadZip` instance from the `MonadComprehensions` extension for `Eff` +- `freshEnumToState` and `runFreshAtomicCounter` for `Fresh` +- `inputToReader`, `mapInput` and `bindInput` for `Input` +- `mapOutput` and `bindOutput` for `Output` +- `runStateIORef`, `runStateMVar` and `runStateTVar` for `State` + ## 0.2.0.0 (2022-02-06) ### Changed diff --git a/cleff.cabal b/cleff.cabal --- a/cleff.cabal +++ b/cleff.cabal @@ -5,7 +5,7 @@ -- see: https://github.com/sol/hpack name: cleff -version: 0.2.0.0 +version: 0.2.1.0 synopsis: Fast and concise extensible effects description: Please see the README on GitHub at category: Control, Effect, Language @@ -46,6 +46,7 @@ Cleff.Internal.Any Cleff.Internal.Base Cleff.Internal.Effect + Cleff.Internal.Instances Cleff.Internal.Interpret Cleff.Internal.Monad Cleff.Internal.TH @@ -100,7 +101,6 @@ , rec-smallarray ==0.1.* , template-haskell >=2.14 && <3 , th-abstraction >=0.2.11 && <0.5 - , transformers >=0.5 && <0.7 , transformers-base >=0.4.5 && <0.5 , unliftio >=0.2.8 && <0.3 if flag(dynamic-ioe) @@ -161,7 +161,6 @@ , rec-smallarray ==0.1.* , template-haskell >=2.14 && <3 , th-abstraction >=0.2.11 && <0.5 - , transformers >=0.5 && <0.7 , transformers-base >=0.4.5 && <0.5 , unliftio >=0.2.8 && <0.3 if flag(dynamic-ioe) @@ -230,7 +229,6 @@ , rec-smallarray ==0.1.* , template-haskell >=2.14 && <3 , th-abstraction >=0.2.11 && <0.5 - , transformers >=0.5 && <0.7 , transformers-base >=0.4.5 && <0.5 , unliftio >=0.2.8 && <0.3 if flag(dynamic-ioe) diff --git a/src/Cleff.hs b/src/Cleff.hs --- a/src/Cleff.hs +++ b/src/Cleff.hs @@ -57,6 +57,7 @@ import Cleff.Internal.Base import Cleff.Internal.Effect +import Cleff.Internal.Instances () import Cleff.Internal.Interpret import Cleff.Internal.Monad import Cleff.Internal.TH diff --git a/src/Cleff/Fresh.hs b/src/Cleff/Fresh.hs --- a/src/Cleff/Fresh.hs +++ b/src/Cleff/Fresh.hs @@ -11,12 +11,14 @@ , -- * Operations fresh , -- * Interpretations - freshIntToState, runFreshUnique + freshIntToState, runFreshAtomicCounter, runFreshUnique ) where import Cleff +import Cleff.Internal.Base (thisIsPureTrustMe) import Cleff.State -import Data.Unique (Unique, newUnique) +import Data.Atomics.Counter (incrCounter, newCounter) +import Data.Unique (Unique, newUnique) -- * Effect @@ -30,13 +32,34 @@ -- * Interpretations --- | Interpret a @'Fresh' 'Int'@ effect in terms of @'State' 'Int'@. +-- | Interpret a @'Fresh' a@ in terms of @'State' a@ for any 'Enum'. Every time 'succ' is called to generate the next +-- value. +-- +-- @since 0.2.1.0 +freshEnumToState :: Enum a => Eff (Fresh a ': es) ~> Eff (State a ': es) +freshEnumToState = reinterpret \case + Fresh -> state \s -> (s, succ s) +{-# INLINE freshEnumToState #-} + +-- | Interpret a @'Fresh' 'Int'@ effect in terms of @'State' 'Int'@. This is a specialized version of +-- 'freshEnumToState'. freshIntToState :: Eff (Fresh Int ': es) ~> Eff (State Int ': es) -freshIntToState = reinterpret \case - Fresh -> state \s -> (s, s + 1) +freshIntToState = freshEnumToState {-# INLINE freshIntToState #-} --- | Interpret a @'Fresh' 'Unique'@ effect in terms of IO actions. +-- | Interpret a @'Fresh' 'Int'@ effect in terms of a 'Data.Atomics.Counter.AtomicCounter'. This is usually faster +-- than 'runFreshUnique'. +-- +-- @since 0.2.1.0 +runFreshAtomicCounter :: Eff (Fresh Int ': es) ~> Eff es +runFreshAtomicCounter m = thisIsPureTrustMe do + counter <- liftIO $ newCounter minBound + reinterpret (\case + Fresh -> liftIO $ incrCounter 1 counter) m +{-# INLINE runFreshAtomicCounter #-} + +-- | Interpret a @'Fresh' 'Unique'@ effect in terms of IO actions. This is slower than 'runFreshAtomicCounter', but it +-- won't overflow on @'maxBound' :: 'Int'@. runFreshUnique :: IOE :> es => Eff (Fresh Unique ': es) ~> Eff es runFreshUnique = interpret \case Fresh -> liftIO newUnique diff --git a/src/Cleff/Input.hs b/src/Cleff/Input.hs --- a/src/Cleff/Input.hs +++ b/src/Cleff/Input.hs @@ -11,10 +11,11 @@ , -- * Operations input, inputs , -- * Interpretations - runInputConst, inputToListState, runInputEff + runInputConst, inputToListState, inputToReader, runInputEff, mapInput, bindInput ) where import Cleff +import Cleff.Reader import Cleff.State -- * Effect @@ -42,13 +43,37 @@ -- | Run an 'Input' effect by going through a list of values. inputToListState :: Eff (Input (Maybe i) ': es) ~> Eff (State [i] ': es) inputToListState = reinterpret \case - Input -> get >>= \case - [] -> pure Nothing - x : xs' -> Just x <$ put xs' + Input -> state \case + [] -> (Nothing, []) + x : xs -> (Just x, xs) {-# INLINE inputToListState #-} +-- | Run an 'Input' in terms of a 'Reader'. +-- +-- @since 0.2.1.0 +inputToReader :: Eff (Input i ': es) ~> Eff (Reader i ': es) +inputToReader = reinterpret \case + Input -> ask +{-# INLINE inputToReader #-} + -- | Run an 'Input' effect by performing a computation for each input request. runInputEff :: Eff es i -> Eff (Input i ': es) ~> Eff es runInputEff m = interpret \case Input -> m {-# INLINE runInputEff #-} + +-- | Transform an 'Input' effect into another one already in the effect stack, by a pure function. +-- +-- @since 0.2.1.0 +mapInput :: Input i' :> es => (i' -> i) -> Eff (Input i ': es) ~> Eff es +mapInput f = interpret \case + Input -> f <$> input +{-# INLINE mapInput #-} + +-- | Transform an 'Input' effect into another one already in the effect stack, by an effectful computation. +-- +-- @since 0.2.1.0 +bindInput :: Input i' :> es => (i' -> Eff es i) -> Eff (Input i ': es) ~> Eff es +bindInput f = interpret \case + Input -> f =<< input +{-# INLINE bindInput #-} diff --git a/src/Cleff/Internal/Base.hs b/src/Cleff/Internal/Base.hs --- a/src/Cleff/Internal/Base.hs +++ b/src/Cleff/Internal/Base.hs @@ -143,20 +143,15 @@ #endif {-# INLINE thisIsPureTrustMe #-} --- | Extract the 'IO' computation out of an 'Eff' given no effect remains on the stack. -runEff :: Eff '[] a -> IO a -runEff m = unEff m emptyEnv -{-# INLINE runEff #-} - -- | Unwrap an 'Eff' computation with side effects into an 'IO' computation, given that all effects other than 'IOE' are -- interpreted. runIOE :: Eff '[IOE] ~> IO -runIOE = runEff . thisIsPureTrustMe +runIOE m = unEff (thisIsPureTrustMe m) emptyEnv {-# INLINE runIOE #-} -- | Unwrap a pure 'Eff' computation into a pure value, given that all effects are interpreted. runPure :: Eff '[] a -> a -runPure = unsafeDupablePerformIO . runEff +runPure m = unsafeDupablePerformIO $ unEff m emptyEnv {-# NOINLINE runPure #-} -- * Effect interpretation diff --git a/src/Cleff/Internal/Instances.hs b/src/Cleff/Internal/Instances.hs new file mode 100644 --- /dev/null +++ b/src/Cleff/Internal/Instances.hs @@ -0,0 +1,80 @@ +{-# OPTIONS_GHC -Wno-orphans #-} +-- | +-- Copyright: (c) 2021 Xy Ren +-- License: BSD3 +-- Maintainer: xy.r@outlook.com +-- Stability: unstable +-- Portability: non-portable (GHC only) +-- +-- This module contains lifted instances of some typeclasses for 'Eff' for convenience. They are all exported in the +-- "Cleff" module so you shouldn't need to import this module. +-- +-- __This is an /internal/ module and its API may change even between minor versions.__ Therefore you should be +-- extra careful if you're to depend on this module. +module Cleff.Internal.Instances () where + +import Cleff.Internal.Monad (Eff) +import Control.Applicative (Applicative (liftA2)) +import Control.Monad.Zip (MonadZip (munzip, mzipWith)) +import Data.String (IsString (fromString)) + +-- | @since 0.2.1.0 +instance Bounded a => Bounded (Eff es a) where + minBound = pure minBound + maxBound = pure maxBound + +-- | @since 0.2.1.0 +instance Num a => Num (Eff es a) where + (+) = liftA2 (+) + (-) = liftA2 (-) + (*) = liftA2 (*) + negate = fmap negate + abs = fmap abs + signum = fmap signum + fromInteger = pure . fromInteger + +-- | @since 0.2.1.0 +instance Fractional a => Fractional (Eff es a) where + (/) = liftA2 (/) + recip = fmap recip + fromRational = pure . fromRational + +-- | @since 0.2.1.0 +instance Floating a => Floating (Eff es a) where + pi = pure pi + exp = fmap exp + log = fmap log + sqrt = fmap sqrt + (**) = liftA2 (**) + logBase = liftA2 logBase + sin = fmap sin + cos = fmap cos + tan = fmap tan + asin = fmap asin + acos = fmap acos + atan = fmap atan + sinh = fmap sinh + cosh = fmap cosh + tanh = fmap tanh + asinh = fmap asinh + acosh = fmap acosh + atanh = fmap atanh + +-- | @since 0.2.1.0 +instance Semigroup a => Semigroup (Eff es a) where + (<>) = liftA2 (<>) + +-- | @since 0.2.1.0 +instance Monoid a => Monoid (Eff es a) where + mempty = pure mempty + +-- | @since 0.2.1.0 +instance IsString a => IsString (Eff es a) where + fromString = pure . fromString + +-- | Compatibility instance for @MonadComprehensions@. +-- +-- @since 0.2.1.0 +instance MonadZip (Eff es) where + mzipWith = liftA2 + munzip x = (fst <$> x, snd <$> x) diff --git a/src/Cleff/Internal/Interpret.hs b/src/Cleff/Internal/Interpret.hs --- a/src/Cleff/Internal/Interpret.hs +++ b/src/Cleff/Internal/Interpret.hs @@ -69,21 +69,29 @@ -- However, note that this function is suited for transforming an existing interpreter into a reinterpreter; if you -- want to define a reinterpreter from scratch, you should still prefer 'reinterpret', which is both easier to use and -- more efficient. +-- +-- @since 0.2.0.0 raiseUnder :: ∀ e' e es. Eff (e ': es) ~> Eff (e ': e' ': es) raiseUnder = raiseNUnder @'[e'] -- | Like 'raiseUnder', but allows introducing multiple effects. This function requires @TypeApplications@. +-- +-- @since 0.2.0.0 raiseNUnder :: ∀ es' e es. KnownList es' => Eff (e ': es) ~> Eff (e ': es' ++ es) raiseNUnder = raiseNUnderN @es' @'[e] -- | Like 'raiseUnder', but allows introducing the effect under multiple effects. This function requires -- @TypeApplications@. +-- +-- @since 0.2.0.0 raiseUnderN :: ∀ e es' es. KnownList es' => Eff (es' ++ es) ~> Eff (es' ++ e ': es) raiseUnderN = raiseNUnderN @'[e] @es' @es -- | A generalization of both 'raiseUnderN' and 'raiseNUnder', allowing introducing multiple effects under multiple -- effects. This function requires @TypeApplications@ and is subject to serious type ambiguity; you most likely will -- need to supply all three type variables explicitly. +-- +-- @since 0.2.0.0 raiseNUnderN :: ∀ es'' es' es. (KnownList es', KnownList es'') => Eff (es' ++ es) ~> Eff (es' ++ (es'' ++ es)) raiseNUnderN = adjust \re -> Rec.concat (Rec.take @es' @(es'' ++ es) re) (Rec.drop @es'' @es (Rec.drop @es' @(es'' ++ es) re)) diff --git a/src/Cleff/Internal/Monad.hs b/src/Cleff/Internal/Monad.hs --- a/src/Cleff/Internal/Monad.hs +++ b/src/Cleff/Internal/Monad.hs @@ -23,13 +23,12 @@ import Cleff.Internal.Any import Cleff.Internal.Effect -import Control.Monad.Fix (MonadFix) -import Control.Monad.Trans.Reader (ReaderT (ReaderT)) -import Data.IntMap.Strict (IntMap) -import qualified Data.IntMap.Strict as Map -import Data.Rec.SmallArray (KnownList, Rec, Subset, pattern (:~:)) -import qualified Data.Rec.SmallArray as Rec -import Type.Reflection (Typeable, typeRep) +import Control.Applicative (Applicative (liftA2)) +import Control.Monad.Fix (MonadFix (mfix)) +import Data.IntMap.Strict (IntMap) +import qualified Data.IntMap.Strict as Map +import Data.Rec.SmallArray (KnownList, Rec, Subset, pattern (:~:)) +import qualified Data.Rec.SmallArray as Rec -- * The 'Eff' monad @@ -41,12 +40,6 @@ newtype InternalHandler e = InternalHandler { runHandler :: ∀ es. e (Eff es) ~> Eff es } --- | @ --- 'show' (handler :: 'InternalHandler' E) == "Handler E" --- @ -instance Typeable e => Show (InternalHandler e) where - showsPrec p _ = ("Handler " ++) . showsPrec p (typeRep @e) - -- | The extensible effect monad. A monad @'Eff' es@ is capable of performing any effect in the /effect stack/ @es@, -- which is a type-level list that holds all effects available. However, most of the times, for flexibility, @es@ -- should be a polymorphic type variable, and you should use the '(:>)' and '(:>>)' operators in constraints to @@ -62,9 +55,35 @@ newtype Eff es a = Eff { unEff :: Env es -> IO a } -- ^ The effect monad receives an effect environment 'Env' that contains all effect handlers and produces an 'IO' -- action. - deriving newtype (Semigroup, Monoid) - deriving (Functor, Applicative, Monad, MonadFix) via (ReaderT (Env es) IO) +instance Functor (Eff es) where + fmap f (Eff x) = Eff (fmap f . x) + {-# INLINE fmap #-} + x <$ Eff y = Eff \es -> x <$ y es + {-# INLINE (<$) #-} + +instance Applicative (Eff es) where + pure = Eff . const . pure + {-# INLINE pure #-} + Eff f <*> Eff x = Eff \es -> f es <*> x es + {-# INLINE (<*>) #-} + Eff x <* Eff y = Eff \es -> x es <* y es + {-# INLINE (<*) #-} + Eff x *> Eff y = Eff \es -> x es *> y es + {-# INLINE (*>) #-} + liftA2 f (Eff x) (Eff y) = Eff \es -> liftA2 f (x es) (y es) + {-# INLINE liftA2 #-} + +instance Monad (Eff es) where + Eff x >>= f = Eff \es -> x es >>= \x' -> unEff (f x') es + {-# INLINE (>>=) #-} + (>>) = (*>) + {-# INLINE (>>) #-} + +instance MonadFix (Eff es) where + mfix f = Eff \es -> mfix \x -> unEff (f x) es + {-# INLINE mfix #-} + -- * Effect environment -- | The /effect environment/ that corresponds effects in the stack to their respective 'InternalHandler's. This @@ -81,10 +100,6 @@ -- | A pointer to 'InternalHandler' in an 'Env'. type role HandlerPtr nominal newtype HandlerPtr (e :: Effect) = HandlerPtr { unHandlerPtr :: Int } - deriving newtype - ( Eq -- ^ Pointer equality. - , Ord -- ^ An arbitrary total order on the pointers. - ) -- | Create an empty 'Env' with no address allocated. emptyEnv :: Env '[] @@ -140,5 +155,7 @@ -- @ -- 'send' = 'sendVia' 'id' -- @ +-- +-- @since 0.2.0.0 sendVia :: e :> es' => (Eff es ~> Eff es') -> e (Eff es) ~> Eff es' sendVia f e = Eff \es -> unEff (f (runHandler (readEnv es) e)) es diff --git a/src/Cleff/Output.hs b/src/Cleff/Output.hs --- a/src/Cleff/Output.hs +++ b/src/Cleff/Output.hs @@ -11,7 +11,7 @@ , -- * Operations output , -- * Interpretations - outputToListState, outputToWriter, ignoreOutput, runOutputEff + outputToListState, outputToWriter, ignoreOutput, runOutputEff, mapOutput, bindOutput ) where import Cleff @@ -30,7 +30,8 @@ -- * Interpretations --- | Run an 'Output' effect by accumulating a list. +-- | Run an 'Output' effect by accumulating a list. Note that outputs are being prepended to the head of the list, so +-- in many cases you would want to 'reverse' the result. outputToListState :: Eff (Output o ': es) ~> Eff (State [o] ': es) outputToListState = reinterpret \case Output x -> modify (x :) @@ -53,3 +54,19 @@ runOutputEff m = interpret \case Output x -> m x {-# INLINE runOutputEff #-} + +-- | Transform an 'Output' effect into another one already in the effect stack, by a pure function. +-- +-- @since 0.2.1.0 +mapOutput :: Output o' :> es => (o -> o') -> Eff (Output o ': es) ~> Eff es +mapOutput f = interpret \case + Output x -> output $ f x +{-# INLINE mapOutput #-} + +-- | Transform an 'Input' effect into another one already in the effect stack, by an effectful computation. +-- +-- @since 0.2.1.0 +bindOutput :: Output o' :> es => (o -> Eff es o') -> Eff (Output o ': es) ~> Eff es +bindOutput f = interpret \case + Output x -> output =<< f x +{-# INLINE bindOutput #-} diff --git a/src/Cleff/State.hs b/src/Cleff/State.hs --- a/src/Cleff/State.hs +++ b/src/Cleff/State.hs @@ -11,15 +11,18 @@ , -- * Operations get, put, state, gets, modify , -- * Interpretations - runState, zoom + runState, runStateIORef, runStateMVar, runStateTVar, zoom ) where import Cleff import Cleff.Internal.Base +import Control.Monad (void) import Data.Atomics (atomicModifyIORefCAS) import Data.Tuple (swap) import Lens.Micro (Lens', (&), (.~), (^.)) -import UnliftIO.IORef (newIORef, readIORef, writeIORef) +import UnliftIO.IORef (IORef, newIORef, readIORef, writeIORef) +import UnliftIO.MVar (MVar, modifyMVar, readMVar, swapMVar) +import UnliftIO.STM (TVar, atomically, readTVar, readTVarIO, writeTVar) -- * Effect @@ -44,6 +47,13 @@ -- * Interpretations +handleIORef :: IOE :> es => IORef s -> Handler (State s) es +handleIORef rs = \case + Get -> readIORef rs + Put s' -> writeIORef rs s' + State f -> liftIO $ atomicModifyIORefCAS rs (swap . f) +{-# INLINE handleIORef #-} + -- | Run the 'State' effect. -- -- __Caveat__: The 'runState' interpreter is implemented with 'Data.IORef.IORef's and there is no way to do arbitrary @@ -58,13 +68,41 @@ runState :: s -> Eff (State s ': es) a -> Eff es (a, s) runState s m = thisIsPureTrustMe do rs <- newIORef s - x <- reinterpret (\case - Get -> readIORef rs - Put s' -> writeIORef rs s' - State f -> liftIO $ atomicModifyIORefCAS rs (swap . f)) m + x <- reinterpret (handleIORef rs) m s' <- readIORef rs pure (x, s') {-# INLINE runState #-} + +-- | Run the 'State' effect in terms of operations on a supplied 'IORef'. The 'state' operation is atomic. +-- +-- @since 0.2.1.0 +runStateIORef :: IOE :> es => IORef s -> Eff (State s ': es) a -> Eff es a +runStateIORef rs = interpret $ handleIORef rs +{-# INLINE runStateIORef #-} + +-- | Run the 'State' effect in terms of operations on a supplied 'MVar'. +-- +-- @since 0.2.1.0 +runStateMVar :: IOE :> es => MVar s -> Eff (State s ': es) a -> Eff es a +runStateMVar rs = interpret \case + Get -> readMVar rs + Put s' -> void $ swapMVar rs s' + State f -> modifyMVar rs \s -> let (x, !s') = f s in pure (s', x) +{-# INLINE runStateMVar #-} + +-- | Run the 'State' effect in terms of operations on a supplied 'TVar'. +-- +-- @since 0.2.1.0 +runStateTVar :: IOE :> es => TVar s -> Eff (State s ': es) a -> Eff es a +runStateTVar rs = interpret \case + Get -> readTVarIO rs + Put s' -> atomically $ writeTVar rs s' + State f -> atomically do + s <- readTVar rs + let (x, !s') = f s + writeTVar rs s' + pure x +{-# INLINE runStateTVar #-} -- | Run a 'State' effect in terms of a larger 'State' via a 'Lens''. zoom :: State t :> es => Lens' t s -> Eff (State s ': es) ~> Eff es