From 9493a3e7bd38b3547096398cf50056149cc17b41 Mon Sep 17 00:00:00 2001 From: Andrzej Rybczak Date: Sun, 22 Dec 2024 16:18:25 +0100 Subject: [PATCH] Add Input and Output effects --- effectful-core/effectful-core.cabal | 7 ++ effectful-core/src/Effectful/Input/Dynamic.hs | 47 ++++++++++++ .../src/Effectful/Input/Static/Action.hs | 63 ++++++++++++++++ .../src/Effectful/Input/Static/Value.hs | 33 +++++++++ .../src/Effectful/Output/Dynamic.hs | 61 +++++++++++++++ .../src/Effectful/Output/Static/Action.hs | 63 ++++++++++++++++ .../Effectful/Output/Static/Array/Local.hs | 74 +++++++++++++++++++ .../Effectful/Output/Static/Array/Shared.hs | 73 ++++++++++++++++++ .../src/Effectful/Writer/Static/Local.hs | 2 + .../src/Effectful/Writer/Static/Shared.hs | 2 + effectful/bench/Main.hs | 18 ++++- effectful/effectful.cabal | 9 ++- 12 files changed, 450 insertions(+), 2 deletions(-) create mode 100644 effectful-core/src/Effectful/Input/Dynamic.hs create mode 100644 effectful-core/src/Effectful/Input/Static/Action.hs create mode 100644 effectful-core/src/Effectful/Input/Static/Value.hs create mode 100644 effectful-core/src/Effectful/Output/Dynamic.hs create mode 100644 effectful-core/src/Effectful/Output/Static/Action.hs create mode 100644 effectful-core/src/Effectful/Output/Static/Array/Local.hs create mode 100644 effectful-core/src/Effectful/Output/Static/Array/Shared.hs diff --git a/effectful-core/effectful-core.cabal b/effectful-core/effectful-core.cabal index 0ff9a82..460474f 100644 --- a/effectful-core/effectful-core.cabal +++ b/effectful-core/effectful-core.cabal @@ -90,6 +90,9 @@ library Effectful.Error.Static Effectful.Exception Effectful.Fail + Effectful.Input.Dynamic + Effectful.Input.Static.Action + Effectful.Input.Static.Value Effectful.Internal.Effect Effectful.Internal.Env Effectful.Internal.Monad @@ -101,6 +104,10 @@ library Effectful.Labeled.State Effectful.Labeled.Writer Effectful.NonDet + Effectful.Output.Dynamic + Effectful.Output.Static.Action + Effectful.Output.Static.Array.Local + Effectful.Output.Static.Array.Shared Effectful.Prim Effectful.Provider Effectful.Provider.List diff --git a/effectful-core/src/Effectful/Input/Dynamic.hs b/effectful-core/src/Effectful/Input/Dynamic.hs new file mode 100644 index 0000000..245e0b6 --- /dev/null +++ b/effectful-core/src/Effectful/Input/Dynamic.hs @@ -0,0 +1,47 @@ +module Effectful.Input.Dynamic + ( -- * Effect + Input + + -- ** Handlers + , runInputAction + , runInputValue + + -- ** Operations + , input + ) where + +import Effectful +import Effectful.Dispatch.Dynamic + +data Input i :: Effect where + Input :: Input i m i + +type instance DispatchOf (Input i) = Dynamic + +---------------------------------------- +-- Handlers + +runInputAction + :: forall i es a + . HasCallStack + => (HasCallStack => Eff es i) + -- ^ The action for input generation. + -> Eff (Input i : es) a + -> Eff es a +runInputAction inputAction = interpret_ $ \case + Input -> inputAction + +runInputValue + :: HasCallStack + => i + -- ^ The input value. + -> Eff (Input i : es) a + -> Eff es a +runInputValue inputValue = interpret_ $ \case + Input -> pure inputValue + +---------------------------------------- +-- Operations + +input :: (HasCallStack, Input i :> es) => Eff es i +input = send Input diff --git a/effectful-core/src/Effectful/Input/Static/Action.hs b/effectful-core/src/Effectful/Input/Static/Action.hs new file mode 100644 index 0000000..2daace4 --- /dev/null +++ b/effectful-core/src/Effectful/Input/Static/Action.hs @@ -0,0 +1,63 @@ +{-# LANGUAGE ImplicitParams #-} +module Effectful.Input.Static.Action + ( -- * Effect + Input + + -- ** Handlers + , runInput + + -- ** Operations + , input + ) where + +import Data.Kind +import GHC.Stack + +import Effectful +import Effectful.Dispatch.Static +import Effectful.Dispatch.Static.Primitive +import Effectful.Internal.Utils + +data Input (i :: Type) :: Effect + +type instance DispatchOf (Input i) = Static NoSideEffects + +-- | Wrapper to prevent a space leak on reconstruction of 'Input' in +-- 'relinkInput' (see https://gitlab.haskell.org/ghc/ghc/-/issues/25520). +newtype InputImpl i es where + InputImpl :: (HasCallStack => Eff es i) -> InputImpl i es + +data instance StaticRep (Input i) where + Input + :: !(Env inputEs) + -> !(InputImpl i inputEs) + -> StaticRep (Input i) + +runInput + :: forall i es a + . HasCallStack + => (HasCallStack => Eff es i) + -- ^ The action for input generation. + -> Eff (Input i : es) a + -> Eff es a +runInput inputAction action = unsafeEff $ \es -> do + inlineBracket + (consEnv (Input es inputImpl) relinkInput es) + unconsEnv + (unEff action) + where + inputImpl = InputImpl $ let ?callStack = thawCallStack ?callStack in inputAction + +input :: (HasCallStack, Input i :> es) => Eff es i +input = unsafeEff $ \es -> do + Input inputEs (InputImpl inputAction) <- getEnv es + -- Corresponds to thawCallStack in runInput. + (`unEff` inputEs) $ withFrozenCallStack inputAction + +---------------------------------------- +-- Helpers + +relinkInput :: Relinker StaticRep (Input i) +relinkInput = Relinker $ \relink (Input inputEs inputAction) -> do + newActionEs <- relink inputEs + pure $ Input newActionEs inputAction diff --git a/effectful-core/src/Effectful/Input/Static/Value.hs b/effectful-core/src/Effectful/Input/Static/Value.hs new file mode 100644 index 0000000..beab39b --- /dev/null +++ b/effectful-core/src/Effectful/Input/Static/Value.hs @@ -0,0 +1,33 @@ +module Effectful.Input.Static.Value + ( -- * Effect + Input + + -- ** Handlers + , runInput + + -- ** Operations + , input + ) where + +import Data.Kind + +import Effectful +import Effectful.Dispatch.Static + +data Input (i :: Type) :: Effect + +type instance DispatchOf (Input i) = Static NoSideEffects +newtype instance StaticRep (Input i) = Input i + +runInput + :: HasCallStack + => i + -- ^ The input. + -> Eff (Input i : es) a + -> Eff es a +runInput = evalStaticRep . Input + +input :: (HasCallStack, Input i :> es) => Eff es i +input = do + Input i <- getStaticRep + pure i diff --git a/effectful-core/src/Effectful/Output/Dynamic.hs b/effectful-core/src/Effectful/Output/Dynamic.hs new file mode 100644 index 0000000..6f1c1cc --- /dev/null +++ b/effectful-core/src/Effectful/Output/Dynamic.hs @@ -0,0 +1,61 @@ +module Effectful.Output.Dynamic + ( -- * Effect + Output + + -- ** Handlers + , runOutputAction + , runOutputLocalArray + , runOutputLocalList + , runOutputSharedArray + , runOutputSharedList + + -- ** Operations + , output + ) where + +import Data.Primitive.Array + +import Effectful +import Effectful.Dispatch.Dynamic +import Effectful.Output.Static.Array.Local qualified as LA +import Effectful.Output.Static.Array.Shared qualified as SA + +data Output o :: Effect where + Output :: o -> Output o m () + +type instance DispatchOf (Output o) = Dynamic + +---------------------------------------- +-- Handlers + +runOutputAction + :: forall o es a + . HasCallStack + => (HasCallStack => o -> Eff es ()) + -- ^ The action for output generation. + -> Eff (Output o : es) a + -> Eff es a +runOutputAction outputAction = interpret_ $ \case + Output o -> outputAction o + +runOutputLocalArray :: HasCallStack => Eff (Output o : es) a -> Eff es (a, Array o) +runOutputLocalArray = reinterpret_ LA.runOutput $ \case + Output o -> LA.output o + +runOutputLocalList :: HasCallStack => Eff (Output o : es) a -> Eff es (a, [o]) +runOutputLocalList = reinterpret_ LA.runOutputList $ \case + Output o -> LA.output o + +runOutputSharedArray :: HasCallStack => Eff (Output o : es) a -> Eff es (a, Array o) +runOutputSharedArray = reinterpret_ SA.runOutput $ \case + Output o -> SA.output o + +runOutputSharedList :: HasCallStack => Eff (Output o : es) a -> Eff es (a, [o]) +runOutputSharedList = reinterpret_ SA.runOutputList $ \case + Output o -> SA.output o + +---------------------------------------- +-- Operations + +output :: (HasCallStack, Output o :> es) => o -> Eff es () +output = send . Output diff --git a/effectful-core/src/Effectful/Output/Static/Action.hs b/effectful-core/src/Effectful/Output/Static/Action.hs new file mode 100644 index 0000000..49f6c0e --- /dev/null +++ b/effectful-core/src/Effectful/Output/Static/Action.hs @@ -0,0 +1,63 @@ +{-# LANGUAGE ImplicitParams #-} +module Effectful.Output.Static.Action + ( -- * Effect + Output + + -- ** Handlers + , runOutput + + -- ** Operations + , output + ) where + +import Data.Kind +import GHC.Stack + +import Effectful +import Effectful.Dispatch.Static +import Effectful.Dispatch.Static.Primitive +import Effectful.Internal.Utils + +data Output (o :: Type) :: Effect + +type instance DispatchOf (Output o) = Static NoSideEffects + +-- | Wrapper to prevent a space leak on reconstruction of 'Output' in +-- 'relinkOutput' (see https://gitlab.haskell.org/ghc/ghc/-/issues/25520). +newtype OutputImpl o es where + OutputImpl :: (HasCallStack => o -> Eff es ()) -> OutputImpl o es + +data instance StaticRep (Output o) where + Output + :: !(Env actionEs) + -> !(OutputImpl o actionEs) + -> StaticRep (Output o) + +runOutput + :: forall o es a + . HasCallStack + => (HasCallStack => o -> Eff es ()) + -- ^ The action for output generation. + -> Eff (Output o : es) a + -> Eff es a +runOutput outputAction action = unsafeEff $ \es -> do + inlineBracket + (consEnv (Output es outputImpl) relinkOutput es) + unconsEnv + (unEff action) + where + outputImpl = OutputImpl $ let ?callStack = thawCallStack ?callStack in outputAction + +output :: (HasCallStack, Output o :> es) => o -> Eff es () +output !o = unsafeEff $ \es -> do + Output actionEs (OutputImpl outputAction) <- getEnv es + -- Corresponds to thawCallStack in runOutput. + (`unEff` actionEs) $ withFrozenCallStack outputAction o + +---------------------------------------- +-- Helpers + +relinkOutput :: Relinker StaticRep (Output o) +relinkOutput = Relinker $ \relink (Output actionEs outputAction) -> do + newActionEs <- relink actionEs + pure $ Output newActionEs outputAction diff --git a/effectful-core/src/Effectful/Output/Static/Array/Local.hs b/effectful-core/src/Effectful/Output/Static/Array/Local.hs new file mode 100644 index 0000000..bd3fe69 --- /dev/null +++ b/effectful-core/src/Effectful/Output/Static/Array/Local.hs @@ -0,0 +1,74 @@ +module Effectful.Output.Static.Array.Local + ( -- * Effect + Output + + -- ** Handlers + , runOutput + , runOutputList + + -- ** Operations + , output + + -- * Re-exports + , Array + ) where + +import Control.Monad.Primitive +import Data.Foldable qualified as F +import Data.Kind +import Data.Primitive.Array + +import Effectful +import Effectful.Dispatch.Static +import Effectful.Internal.Utils +import Effectful.Internal.Env + +data Output (o :: Type) :: Effect + +type instance DispatchOf (Output o) = Static NoSideEffects +data instance StaticRep (Output o) = Output !Int !(MutableArray RealWorld o) + +runOutput :: HasCallStack => Eff (Output o : es) a -> Eff es (a, Array o) +runOutput = runOutputImpl $ \(Output size arr) -> do + freezeArray arr 0 size + +runOutputList :: HasCallStack => Eff (Output o : es) a -> Eff es (a, [o]) +runOutputList = runOutputImpl $ \(Output size arr) -> do + take size . F.toList <$> unsafeFreezeArray arr + +output :: (HasCallStack, Output o :> es) => o -> Eff es () +output !o = unsafeEff $ \es -> do + Output size arr0 <- getEnv es + let len0 = sizeofMutableArray arr0 + arr <- case size `compare` len0 of + GT -> error $ "size (" ++ show size ++ ") > len0 (" ++ show len0 ++ ")" + LT -> pure arr0 + EQ -> do + let len = growCapacity len0 + arr <- newArray len undefinedValue + copyMutableArray arr 0 arr0 0 size + pure arr + writeArray arr size o + putEnv es $ Output (size + 1) arr + +---------------------------------------- +-- Helpers + +runOutputImpl + :: HasCallStack + => (StaticRep (Output o) -> IO acc) + -> Eff (Output o : es) a + -> Eff es (a, acc) +runOutputImpl f action = unsafeEff $ \es0 -> do + arr <- newArray 0 undefinedValue + inlineBracket + (consEnv (Output 0 arr) relinkOutput es0) + unconsEnv + (\es -> (,) <$> unEff action es <*> (f =<< getEnv es)) + where + relinkOutput = Relinker $ \_ (Output size arr0) -> do + arr <- cloneMutableArray arr0 0 (sizeofMutableArray arr0) + pure $ Output size arr + +undefinedValue :: HasCallStack => a +undefinedValue = error "Undefined value" diff --git a/effectful-core/src/Effectful/Output/Static/Array/Shared.hs b/effectful-core/src/Effectful/Output/Static/Array/Shared.hs new file mode 100644 index 0000000..6127342 --- /dev/null +++ b/effectful-core/src/Effectful/Output/Static/Array/Shared.hs @@ -0,0 +1,73 @@ +module Effectful.Output.Static.Array.Shared + ( -- * Effect + Output + + -- ** Handlers + , runOutput + , runOutputList + + -- ** Operations + , output + + -- * Re-exports + , Array + ) where + +import Control.Concurrent.MVar.Strict +import Control.Monad.Primitive +import Data.Foldable qualified as F +import Data.Kind +import Data.Primitive.Array + +import Effectful +import Effectful.Dispatch.Static +import Effectful.Internal.Utils +import Effectful.Internal.Env + +data Output (o :: Type) :: Effect + +data OutputData o = OutputData !Int !(MutableArray RealWorld o) + +type instance DispatchOf (Output o) = Static NoSideEffects +newtype instance StaticRep (Output o) = Output (MVar' (OutputData o)) + +runOutput :: HasCallStack => Eff (Output o : es) a -> Eff es (a, Array o) +runOutput = runOutputImpl $ \(OutputData size arr) -> do + freezeArray arr 0 size + +runOutputList :: HasCallStack => Eff (Output o : es) a -> Eff es (a, [o]) +runOutputList = runOutputImpl $ \(OutputData size arr) -> do + take size . F.toList <$> unsafeFreezeArray arr + +output :: (HasCallStack, Output o :> es) => o -> Eff es () +output !o = unsafeEff $ \es -> do + Output v <- getEnv es + modifyMVar'_ v $ \(OutputData size arr0) -> do + let len0 = sizeofMutableArray arr0 + arr <- case size `compare` len0 of + GT -> error $ "size (" ++ show size ++ ") > len0 (" ++ show len0 ++ ")" + LT -> pure arr0 + EQ -> do + let len = growCapacity len0 + arr <- newArray len undefinedValue + copyMutableArray arr 0 arr0 0 size + pure arr + writeArray arr size o + pure $ OutputData (size + 1) arr + +---------------------------------------- +-- Helpers + +runOutputImpl + :: HasCallStack + => (OutputData o -> IO acc) + -> Eff (Output o : es) a + -> Eff es (a, acc) +runOutputImpl f action = do + v <- unsafeEff_ $ newMVar' . OutputData 0 =<< newArray 0 undefinedValue + a <- evalStaticRep (Output v) action + acc <- unsafeEff_ $ f =<< readMVar' v + pure (a, acc) + +undefinedValue :: HasCallStack => a +undefinedValue = error "Undefined value" diff --git a/effectful-core/src/Effectful/Writer/Static/Local.hs b/effectful-core/src/Effectful/Writer/Static/Local.hs index 05057fd..8380946 100644 --- a/effectful-core/src/Effectful/Writer/Static/Local.hs +++ b/effectful-core/src/Effectful/Writer/Static/Local.hs @@ -8,6 +8,8 @@ -- is inefficient. __This applies, in particular, to the standard list type__, -- which makes the 'Writer' effect pretty niche. -- +-- __If you just want to accumulate values, use "Effectful.Output.Static.Array.Local".__ +-- -- /Note:/ while the 'Control.Monad.Trans.Writer.Strict.Writer' from the -- @transformers@ package includes additional operations -- 'Control.Monad.Trans.Writer.Strict.pass' and diff --git a/effectful-core/src/Effectful/Writer/Static/Shared.hs b/effectful-core/src/Effectful/Writer/Static/Shared.hs index 55a4a8f..4d5b29b 100644 --- a/effectful-core/src/Effectful/Writer/Static/Shared.hs +++ b/effectful-core/src/Effectful/Writer/Static/Shared.hs @@ -8,6 +8,8 @@ -- is inefficient. __This applies, in particular, to the standard list type__, -- which makes the 'Writer' effect pretty niche. -- +-- __If you just want to accumulate values, use "Effectful.Output.Static.Array.Shared".__ +-- -- /Note:/ while the 'Control.Monad.Trans.Writer.Strict.Writer' from the -- @transformers@ package includes additional operations -- 'Control.Monad.Trans.Writer.Strict.pass' and diff --git a/effectful/bench/Main.hs b/effectful/bench/Main.hs index 2d998bf..5175506 100644 --- a/effectful/bench/Main.hs +++ b/effectful/bench/Main.hs @@ -15,9 +15,25 @@ import Countdown import FileSizes import Unlift +---------------------------------------- + +import Data.Foldable +import Effectful +import Effectful.Output.Dynamic + +benchOutput + :: (forall r es. Eff (Output Int : es) r -> Eff es (r, x)) + -> Int + -> IO x +benchOutput run n = fmap snd . runEff . run $ forM_ [1..n] output + main :: IO () main = defaultMain - [ concurrencyBenchmark + [ bgroup "output" + [ bench "array" $ nfAppIO (benchOutput runOutputLocalArray) 1000000 + , bench "list" $ nfAppIO (benchOutput runOutputLocalList) 1000000 + ] + , concurrencyBenchmark , unliftBenchmark , bgroup "countdown" $ map countdown [1000, 2000, 3000] , bgroup "countdown (extra)" $ map countdownExtra [1000, 2000, 3000] diff --git a/effectful/effectful.cabal b/effectful/effectful.cabal index 0f4d484..5626b0e 100644 --- a/effectful/effectful.cabal +++ b/effectful/effectful.cabal @@ -115,16 +115,23 @@ library reexported-modules: Effectful , Effectful.Dispatch.Dynamic , Effectful.Dispatch.Static - , Effectful.Error.Static , Effectful.Error.Dynamic + , Effectful.Error.Static , Effectful.Exception , Effectful.Fail + , Effectful.Input.Dynamic + , Effectful.Input.Static.Action + , Effectful.Input.Static.Value , Effectful.Labeled , Effectful.Labeled.Error , Effectful.Labeled.Reader , Effectful.Labeled.State , Effectful.Labeled.Writer , Effectful.NonDet + , Effectful.Output.Dynamic + , Effectful.Output.Static.Action + , Effectful.Output.Static.Array.Local + , Effectful.Output.Static.Array.Shared , Effectful.Prim , Effectful.Provider , Effectful.Provider.List