atelier-core 0.7.3.0 → 0.8.0.0
raw patch · 27 files changed
+667/−493 lines, 27 filesPVP ok
version bump matches the API change (PVP)
API changes (from Hackage documentation)
- Atelier.Effects.Publishing.Pub: [Publish] :: forall event (a :: Type -> Type). event -> Pub event a ()
- Atelier.Effects.Publishing.Pub: consume :: forall event (es :: [Effect]) a. (event -> Eff es ()) -> Eff (Pub event ': es) a -> Eff es a
- Atelier.Effects.Publishing.Pub: data Pub event (a :: Type -> Type) b
- Atelier.Effects.Publishing.Pub: map :: forall e1 e2 (es :: [Effect]) a. Pub e2 :> es => (e1 -> e2) -> Eff (Pub e1 ': es) a -> Eff es a
- Atelier.Effects.Publishing.Pub: mapM :: forall e1 e2 (es :: [Effect]) a. Pub e2 :> es => (e1 -> Eff es e2) -> Eff (Pub e1 ': es) a -> Eff es a
- Atelier.Effects.Publishing.Pub: publish :: forall event (es :: [Effect]). (HasCallStack, Pub event :> es) => event -> Eff es ()
- Atelier.Effects.Publishing.Pub: runNoOp :: forall event (es :: [(Type -> Type) -> Type -> Type]) a. Eff (Pub event ': es) a -> Eff es a
- Atelier.Effects.Publishing.Pub: toWriter :: forall event (es :: [Effect]) a. Writer [event] :> es => Eff (Pub event ': es) a -> Eff es a
- Atelier.Effects.Publishing.Sub: [ListenWith] :: forall (a :: Type -> Type) event. a () -> (UTCTime -> event -> a ()) -> Sub event a Void
- Atelier.Effects.Publishing.Sub: data Sub event (a :: Type -> Type) b
- Atelier.Effects.Publishing.Sub: forkListener :: forall event (es :: [Effect]). (Conc :> es, Concurrent :> es, Sub event :> es) => (UTCTime -> event -> Eff es ()) -> Eff es ()
- Atelier.Effects.Publishing.Sub: forkListener_ :: forall event (es :: [Effect]). (Conc :> es, Concurrent :> es, Sub event :> es) => (event -> Eff es ()) -> Eff es ()
- Atelier.Effects.Publishing.Sub: instance GHC.Show.Show (Atelier.Effects.Publishing.Sub.OnceEx ev)
- Atelier.Effects.Publishing.Sub: listen :: forall event (es :: [Effect]). Sub event :> es => (UTCTime -> event -> Eff es ()) -> Eff es Void
- Atelier.Effects.Publishing.Sub: listenOnce :: forall event (es :: [Effect]). Sub event :> es => Eff es (UTCTime, event)
- Atelier.Effects.Publishing.Sub: listenOnce_ :: forall event (es :: [Effect]). Sub event :> es => Eff es event
- Atelier.Effects.Publishing.Sub: listenUntil :: forall event (es :: [Effect]) a. Sub event :> es => (UTCTime -> event -> Maybe a) -> Eff es (UTCTime, a)
- Atelier.Effects.Publishing.Sub: listenUntilM :: forall event (es :: [Effect]) a. Sub event :> es => (UTCTime -> event -> Eff es (Maybe a)) -> Eff es (UTCTime, a)
- Atelier.Effects.Publishing.Sub: listenUntilM_ :: forall event (es :: [Effect]) a. Sub event :> es => (event -> Eff es (Maybe a)) -> Eff es a
- Atelier.Effects.Publishing.Sub: listenUntil_ :: forall event (es :: [Effect]) a. Sub event :> es => (event -> Maybe a) -> Eff es a
- Atelier.Effects.Publishing.Sub: listenWith :: forall event (es :: [Effect]). (HasCallStack, Sub event :> es) => Eff es () -> (UTCTime -> event -> Eff es ()) -> Eff es Void
- Atelier.Effects.Publishing.Sub: listenWith_ :: forall event (es :: [Effect]). Sub event :> es => Eff es () -> (event -> Eff es ()) -> Eff es Void
- Atelier.Effects.Publishing.Sub: listen_ :: forall event (es :: [Effect]). Sub event :> es => (event -> Eff es ()) -> Eff es Void
- Atelier.Types.QuietSnake: instance (Data.Aeson.Types.Class.GToJSON Data.Aeson.Types.Generic.Zero (GHC.Generics.Rep a), GHC.Generics.Generic a) => Data.Aeson.Types.ToJSON.ToJSON (Atelier.Types.QuietSnake.QuietSnake a)
- Atelier.Types.QuietSnake: instance (Data.Aeson.Types.FromJSON.GFromJSON Data.Aeson.Types.Generic.Zero (GHC.Generics.Rep a), GHC.Generics.Generic a) => Data.Aeson.Types.FromJSON.FromJSON (Atelier.Types.QuietSnake.QuietSnake a)
- Atelier.Types.QuietSnake: instance Data.Default.Internal.Default a => Data.Default.Internal.Default (Atelier.Types.QuietSnake.QuietSnake a)
+ Atelier.Effects.Input: map :: forall a (es :: [Effect]) b x. Input a :> es => (a -> b) -> Eff (Input b ': es) x -> Eff es x
+ Atelier.Effects.Input: withConst :: forall i (es :: [(Type -> Type) -> Type -> Type]) a. i -> Eff (Input i ': es) a -> Eff es a
+ Atelier.Effects.Input: withEff :: forall (es :: [Effect]) i a. Eff es i -> Eff (Input i ': es) a -> Eff es a
+ Atelier.Effects.Log: instance Data.Aeson.Types.ToJSON.ToJSON Atelier.Effects.Log.Config
+ Atelier.Effects.Log: instance Data.Aeson.Types.ToJSON.ToJSON Atelier.Effects.Log.Severity
+ Atelier.Effects.PubSub: run :: forall event (es :: [Effect]) a. (Chan :> es, Clock :> es) => Eff (Pub event ': (Sub event ': es)) a -> Eff es a
+ Atelier.Effects.PubSub.Pub: [Publish] :: forall event (a :: Type -> Type). event -> Pub event a ()
+ Atelier.Effects.PubSub.Pub: consume :: forall event (es :: [Effect]) a. (event -> Eff es ()) -> Eff (Pub event ': es) a -> Eff es a
+ Atelier.Effects.PubSub.Pub: data Pub event (a :: Type -> Type) b
+ Atelier.Effects.PubSub.Pub: map :: forall e1 e2 (es :: [Effect]) a. Pub e2 :> es => (e1 -> e2) -> Eff (Pub e1 ': es) a -> Eff es a
+ Atelier.Effects.PubSub.Pub: mapM :: forall e1 e2 (es :: [Effect]) a. Pub e2 :> es => (e1 -> Eff es e2) -> Eff (Pub e1 ': es) a -> Eff es a
+ Atelier.Effects.PubSub.Pub: publish :: forall event (es :: [Effect]). (HasCallStack, Pub event :> es) => event -> Eff es ()
+ Atelier.Effects.PubSub.Pub: runNoOp :: forall event (es :: [(Type -> Type) -> Type -> Type]) a. Eff (Pub event ': es) a -> Eff es a
+ Atelier.Effects.PubSub.Pub: toWriter :: forall event (es :: [Effect]) a. Writer [event] :> es => Eff (Pub event ': es) a -> Eff es a
+ Atelier.Effects.PubSub.Sub: [ListenWith] :: forall (a :: Type -> Type) event. a () -> (UTCTime -> event -> a ()) -> Sub event a Void
+ Atelier.Effects.PubSub.Sub: data Sub event (a :: Type -> Type) b
+ Atelier.Effects.PubSub.Sub: forkListener :: forall event (es :: [Effect]). (Conc :> es, Concurrent :> es, Sub event :> es) => (UTCTime -> event -> Eff es ()) -> Eff es ()
+ Atelier.Effects.PubSub.Sub: forkListener_ :: forall event (es :: [Effect]). (Conc :> es, Concurrent :> es, Sub event :> es) => (event -> Eff es ()) -> Eff es ()
+ Atelier.Effects.PubSub.Sub: instance GHC.Show.Show (Atelier.Effects.PubSub.Sub.OnceEx ev)
+ Atelier.Effects.PubSub.Sub: listen :: forall event (es :: [Effect]). Sub event :> es => (UTCTime -> event -> Eff es ()) -> Eff es Void
+ Atelier.Effects.PubSub.Sub: listenOnce :: forall event (es :: [Effect]). Sub event :> es => Eff es (UTCTime, event)
+ Atelier.Effects.PubSub.Sub: listenOnce_ :: forall event (es :: [Effect]). Sub event :> es => Eff es event
+ Atelier.Effects.PubSub.Sub: listenUntil :: forall event (es :: [Effect]) a. Sub event :> es => (UTCTime -> event -> Maybe a) -> Eff es (UTCTime, a)
+ Atelier.Effects.PubSub.Sub: listenUntilM :: forall event (es :: [Effect]) a. Sub event :> es => (UTCTime -> event -> Eff es (Maybe a)) -> Eff es (UTCTime, a)
+ Atelier.Effects.PubSub.Sub: listenUntilM_ :: forall event (es :: [Effect]) a. Sub event :> es => (event -> Eff es (Maybe a)) -> Eff es a
+ Atelier.Effects.PubSub.Sub: listenUntil_ :: forall event (es :: [Effect]) a. Sub event :> es => (event -> Maybe a) -> Eff es a
+ Atelier.Effects.PubSub.Sub: listenWith :: forall event (es :: [Effect]). (HasCallStack, Sub event :> es) => Eff es () -> (UTCTime -> event -> Eff es ()) -> Eff es Void
+ Atelier.Effects.PubSub.Sub: listenWith_ :: forall event (es :: [Effect]). Sub event :> es => Eff es () -> (event -> Eff es ()) -> Eff es Void
+ Atelier.Effects.PubSub.Sub: listen_ :: forall event (es :: [Effect]). Sub event :> es => (event -> Eff es ()) -> Eff es Void
+ Atelier.Effects.Reader: project :: forall a (es :: [Effect]) b x. Reader a :> es => (a -> b) -> Eff (Reader b ': es) x -> Eff es x
+ Atelier.Types.JSON.QuietSnake: QuietSnake :: a -> QuietSnake a
+ Atelier.Types.JSON.QuietSnake: [getQuietSnake] :: QuietSnake a -> a
+ Atelier.Types.JSON.QuietSnake: instance (Data.Aeson.Types.Class.GToJSON Data.Aeson.Types.Generic.Zero (GHC.Generics.Rep a), GHC.Generics.Generic a) => Data.Aeson.Types.ToJSON.ToJSON (Atelier.Types.JSON.QuietSnake.QuietSnake a)
+ Atelier.Types.JSON.QuietSnake: instance (Data.Aeson.Types.FromJSON.GFromJSON Data.Aeson.Types.Generic.Zero (GHC.Generics.Rep a), GHC.Generics.Generic a) => Data.Aeson.Types.FromJSON.FromJSON (Atelier.Types.JSON.QuietSnake.QuietSnake a)
+ Atelier.Types.JSON.QuietSnake: instance Data.Default.Internal.Default a => Data.Default.Internal.Default (Atelier.Types.JSON.QuietSnake.QuietSnake a)
+ Atelier.Types.JSON.QuietSnake: newtype QuietSnake a
+ Atelier.Types.JSON.QuietSnake: options :: Options
+ Atelier.Types.JSON.ReadShow: ReadShow :: a -> ReadShow a
+ Atelier.Types.JSON.ReadShow: [getReadShow] :: ReadShow a -> a
+ Atelier.Types.JSON.ReadShow: instance (GHC.Read.Read a, Data.Typeable.Internal.Typeable a) => Data.Aeson.Types.FromJSON.FromJSON (Atelier.Types.JSON.ReadShow.ReadShow a)
+ Atelier.Types.JSON.ReadShow: instance GHC.Show.Show a => Data.Aeson.Types.ToJSON.ToJSON (Atelier.Types.JSON.ReadShow.ReadShow a)
+ Atelier.Types.JSON.ReadShow: newtype ReadShow a
+ Atelier.Types.JSON.StringLiteral: StringLiteral :: a -> StringLiteral (literal :: Symbol) a
+ Atelier.Types.JSON.StringLiteral: [getStringLiteral] :: StringLiteral (literal :: Symbol) a -> a
+ Atelier.Types.JSON.StringLiteral: instance (Data.Default.Internal.Default a, GHC.TypeLits.KnownSymbol lit) => Data.Aeson.Types.FromJSON.FromJSON (Atelier.Types.JSON.StringLiteral.StringLiteral lit a)
+ Atelier.Types.JSON.StringLiteral: instance GHC.TypeLits.KnownSymbol lit => Data.Aeson.Types.ToJSON.ToJSON (Atelier.Types.JSON.StringLiteral.StringLiteral lit a)
+ Atelier.Types.JSON.StringLiteral: newtype StringLiteral (literal :: Symbol) a
Files
- CHANGELOG.md +43/−0
- atelier-core.cabal +10/−3
- src/Atelier/Effects/Cache/Config.hs +1/−1
- src/Atelier/Effects/Input.hs +28/−4
- src/Atelier/Effects/Internal/Coroutine.hs +2/−2
- src/Atelier/Effects/Iterator.hs +2/−2
- src/Atelier/Effects/Log.hs +8/−5
- src/Atelier/Effects/PubSub.hs +36/−0
- src/Atelier/Effects/PubSub/Pub.hs +58/−0
- src/Atelier/Effects/PubSub/Sub.hs +155/−0
- src/Atelier/Effects/Publishing.hs +6/−27
- src/Atelier/Effects/Publishing/Pub.hs +3/−53
- src/Atelier/Effects/Publishing/Sub.hs +3/−150
- src/Atelier/Effects/Reader.hs +13/−0
- src/Atelier/Types/JSON/QuietSnake.hs +59/−0
- src/Atelier/Types/JSON/ReadShow.hs +38/−0
- src/Atelier/Types/JSON/StringLiteral.hs +29/−0
- src/Atelier/Types/JsonReadShow.hs +8/−35
- src/Atelier/Types/QuietSnake.hs +2/−48
- test/Unit/Atelier/ConfigSpec.hs +1/−1
- test/Unit/Atelier/Effects/Conc/TeardownStressSpec.hs +5/−5
- test/Unit/Atelier/Effects/IteratorSpec.hs +5/−5
- test/Unit/Atelier/Effects/PubSub/PubSpec.hs +62/−0
- test/Unit/Atelier/Effects/PubSubSpec.hs +89/−0
- test/Unit/Atelier/Effects/Publishing/PubSpec.hs +0/−62
- test/Unit/Atelier/Effects/PublishingSpec.hs +0/−89
- test/Unit/Atelier/Types/WithDefaultsSpec.hs +1/−1
CHANGELOG.md view
@@ -7,6 +7,49 @@ ## [Unreleased] +## [0.8.0.0] - 2026-10-20++### Added++- `Atelier.Types.JSON.StringLiteral`: helper `newtype` for parsing and encoding+ values as exact string literals, regardless of their `Show` and `Read`+ instances.+- `Atelier.Types.JSON.ReadShow`: a copy of `Atelier.Types.JsonReadShow`, but+ with a better name.+- `Atelier.Types.JSON.QuietSnake`: a copy of `Atelier.Types.QuietSnake`, but+ with a better name.+- `Atelier.Effects.Input.withEff`: a copy of+ `Atelier.Effects.Input.runInputEff`, but with a better name.+- `Atelier.Effects.Input.withConst`: a copy of+ `Atelier.Effects.Input.runInputConst`, but with a better name.+- `Atelier.Effects.PubSub`: a copy of+ `Atelier.Effects.Publishing`, but with a better name.+- `Atelier.Effects.PubSub.Pub`: a copy of+ `Atelier.Effects.Publishing.Pub`, but with a better name.+- `Atelier.Effects.PubSub.Sub`: a copy of+ `Atelier.Effects.Publishing.Sub`, but with a better name.+- `Atelier.Effects.Reader.project`: a simple way to expose parts of another+ `Reader a` as another `Reader` effect.+- `Atelier.Effects.Input.map`: a function to transform an existing effect.+- `Atelier.Effects.Log.Config`: gets a `ToJSON` instance.+- `Atelier.Effects.Log.Severity`: gets a `ToJSON` instance.++### Changed++- `Atelier.Effects.Log.Config`: its `FromJSON` instance now fails gracefully+ using the `Default` instance.++### Deprecated++- `Atelier.Types.JsonReadShow`: superseded by `Atelier.Types.JSON.ReadShow`.+- `Atelier.Types.QuietSnake`: superseded by `Atelier.Types.JSON.QuietSnake`.+- `Atelier.Effects.Input.runInputEff`: superseded by `Atelier.Effects.Input.withEff`.+- `Atelier.Effects.Input.runInputConst`: superseded by `Atelier.Effects.Input.withConst`.+- `Atelier.Effects.Publishing`: superseded by `Atelier.Effects.PubSub`.+- `Atelier.Effects.Publishing.runPubSub`: superseded by `Atelier.Effects.PubSub.run`.+- `Atelier.Effects.Publishing.Pub`: superseded by `Atelier.Effects.PubSub.Pub`.+- `Atelier.Effects.Publishing.Sub`: superseded by `Atelier.Effects.PubSub.Sub`.+ ## [0.7.3.0] - 2026-10-02 ### Added
atelier-core.cabal view
@@ -5,7 +5,7 @@ -- see: https://github.com/sol/hpack name: atelier-core-version: 0.7.3.0+version: 0.8.0.0 synopsis: Foundational Effectful-based effects and utilities description: Core effects and utilities for effect-based applications, built on Effectful — part of the atelier toolkit. category: Control@@ -61,6 +61,10 @@ Atelier.Effects.Publishing Atelier.Effects.Publishing.Pub Atelier.Effects.Publishing.Sub+ Atelier.Effects.PubSub+ Atelier.Effects.PubSub.Pub+ Atelier.Effects.PubSub.Sub+ Atelier.Effects.Reader Atelier.Effects.Tally Atelier.Effects.Timeout Atelier.Effects.UUID@@ -70,6 +74,9 @@ Atelier.Time Atelier.Types.Base64 Atelier.Types.HttpApiDataReadShow+ Atelier.Types.JSON.QuietSnake+ Atelier.Types.JSON.ReadShow+ Atelier.Types.JSON.StringLiteral Atelier.Types.JsonReadShow Atelier.Types.QuietSnake Atelier.Types.Semaphore@@ -160,8 +167,8 @@ Unit.Atelier.Effects.FileWatcherSpec Unit.Atelier.Effects.IteratorSpec Unit.Atelier.Effects.LogSpec- Unit.Atelier.Effects.Publishing.PubSpec- Unit.Atelier.Effects.PublishingSpec+ Unit.Atelier.Effects.PubSub.PubSpec+ Unit.Atelier.Effects.PubSubSpec Unit.Atelier.Effects.TallySpec Unit.Atelier.Effects.YieldSpec Unit.Atelier.Types.Semaphore.STMSpec
src/Atelier/Effects/Cache/Config.hs view
@@ -12,7 +12,7 @@ import Data.Default (Default (..)) import Data.Time (NominalDiffTime) -import Atelier.Types.QuietSnake (QuietSnake (..))+import Atelier.Types.JSON.QuietSnake (QuietSnake (..)) -- | Configuration for a TTL-evicting cache
src/Atelier/Effects/Input.hs view
@@ -6,10 +6,13 @@ module Atelier.Effects.Input ( Input , input- , runInputEff- , runInputConst+ , withEff+ , withConst , toReader , fromState+ , runInputEff+ , runInputConst+ , map ) where @@ -18,6 +21,7 @@ import Effectful.Reader.Static (Reader, runReader) import Effectful.State.Static.Shared (State) import Effectful.TH (makeEffect)+import Prelude hiding (map) import Effectful.State.Static.Shared qualified as State @@ -44,16 +48,30 @@ -- | Runs the passed effectful action every time 'input' is invoked. runInputEff :: Eff es i -> Eff (Input i : es) a -> Eff es a-runInputEff mk = interpret_ \Input -> mk+runInputEff = withEff+{-# DEPRECATED runInputEff "Use 'Atelier.Effects.Input.withEff' instead." #-} +-- | Runs the passed effectful action every time 'input' is invoked.+withEff :: Eff es i -> Eff (Input i : es) a -> Eff es a+withEff mk = interpret_ \Input -> mk++ -- | Provides the same value for every invocation of the 'input' operation. -- This is equivalent to using 'Effectful.Reader.Static' or -- 'Effectful.Reader.Local', but is available here for testing. runInputConst :: i -> Eff (Input i : es) a -> Eff es a-runInputConst = runInputEff . pure+runInputConst = withConst+{-# DEPRECATED runInputConst "Use 'Atelier.Effects.Input.withConst' instead." #-} +-- | Provides the same value for every invocation of the 'input' operation.+-- This is equivalent to using 'Effectful.Reader.Static' or+-- 'Effectful.Reader.Local', but is available here for testing.+withConst :: i -> Eff (Input i : es) a -> Eff es a+withConst = runInputEff . pure++ -- | Retrieves the value once, and exposes it as a 'Reader' effect. toReader :: (Input i :> es) => Eff (Reader i : es) a -> Eff es a toReader act = do@@ -63,3 +81,9 @@ fromState :: (State i :> es) => Eff (Input i : es) a -> Eff es a fromState = interpret_ \Input -> State.get+++-- | Create a new 'Input' effect based on an existing one, effectively+-- "mapping" the existing effect into a new one.+map :: (Input a :> es) => (a -> b) -> Eff (Input b : es) x -> Eff es x+map f = withEff $ f <$> input
src/Atelier/Effects/Internal/Coroutine.hs view
@@ -53,11 +53,11 @@ import Atelier.Effects.Chan (Chan) import Atelier.Effects.Conc (Conc)-import Atelier.Effects.Publishing.Sub (Sub)+import Atelier.Effects.PubSub.Sub (Sub) import Atelier.Effects.Chan qualified as Chan import Atelier.Effects.Conc qualified as Conc-import Atelier.Effects.Publishing.Sub qualified as Sub+import Atelier.Effects.PubSub.Sub qualified as Sub -- * Yield
src/Atelier/Effects/Iterator.hs view
@@ -18,11 +18,11 @@ import Atelier.Effects.Chan (Chan) import Atelier.Effects.Conc (Conc)-import Atelier.Effects.Publishing.Sub (Sub)+import Atelier.Effects.PubSub.Sub (Sub) import Atelier.Effects.Chan qualified as Chan import Atelier.Effects.Conc qualified as Conc-import Atelier.Effects.Publishing.Sub qualified as Sub+import Atelier.Effects.PubSub.Sub qualified as Sub -- | A pull-based iterator of (potentially infinite) values.
src/Atelier/Effects/Log.hs view
@@ -47,7 +47,7 @@ ) where -import Data.Aeson (FromJSON (..))+import Data.Aeson (FromJSON (..), ToJSON) import Data.Default (Default (..)) import Data.List (lookup) import Effectful (Effect, IOE)@@ -60,8 +60,9 @@ import Data.ByteString.Char8 qualified as B8 import Atelier.Effects.Env (Env, getEnvironment)-import Atelier.Types.JsonReadShow (JsonReadShow (..))-import Atelier.Types.QuietSnake (QuietSnake (..))+import Atelier.Types.JSON.QuietSnake (QuietSnake (..))+import Atelier.Types.JSON.ReadShow (ReadShow (..))+import Atelier.Types.WithDefaults (WithDefaults (..)) -- | Effect for structured logging with hierarchical namespaces.@@ -105,7 +106,8 @@ -- ^ Messages below this severity are discarded. } deriving stock (Eq, Generic, Show)- deriving (FromJSON) via QuietSnake Config+ deriving (ToJSON) via QuietSnake Config+ deriving (FromJSON) via WithDefaults (QuietSnake Config) -- | Log severity levels, ordered from least to most severe.@@ -119,7 +121,8 @@ | -- | A failure that needs attention. ERROR deriving stock (Bounded, Enum, Eq, Ord, Read, Show)- deriving (FromJSON) via (JsonReadShow Severity)+ deriving (FromJSON) via ReadShow Severity+ deriving (ToJSON) via ReadShow Severity instance Default Config where
+ src/Atelier/Effects/PubSub.hs view
@@ -0,0 +1,36 @@+module Atelier.Effects.PubSub (run) where++import Data.Time (UTCTime)+import Effectful.Dispatch.Dynamic (interpret, interpret_, localSeqUnlift)++import Atelier.Effects.Chan (Chan)+import Atelier.Effects.Clock (Clock)+import Atelier.Effects.PubSub.Pub (Pub (..))+import Atelier.Effects.PubSub.Sub (Sub (..))++import Atelier.Effects.Chan qualified as Chan+import Atelier.Effects.Clock qualified as Clock+++-- | Runs 'Pub' and 'Sub' effects with an internal channel for a specific event+-- type.+run+ :: forall event es a+ . (Chan :> es, Clock :> es)+ => Eff (Pub event : Sub event : es) a -> Eff es a+run action = do+ (inChan, _) <- Chan.newChan @(UTCTime, event)+ let handlePub = interpret_ \case+ Publish event -> do+ timestamp <- Clock.currentTime+ Chan.writeChan inChan (timestamp, event)++ handleSub = interpret \env -> \case+ ListenWith onSubscribed listener -> localSeqUnlift env \unlift -> do+ chan <- Chan.dupChan inChan+ unlift onSubscribed+ forever do+ (timestamp, event) <- Chan.readChan chan+ unlift $ listener timestamp event++ handleSub . handlePub $ action
+ src/Atelier/Effects/PubSub/Pub.hs view
@@ -0,0 +1,58 @@+module Atelier.Effects.PubSub.Pub+ ( -- * Effect+ Pub (..)+ , publish++ -- * Interpeters+ , runNoOp+ , toWriter+ , map+ , mapM+ , consume+ )+where++import Effectful (Effect)+import Effectful.Dispatch.Dynamic (interpret_)+import Effectful.TH (makeEffect)+import Effectful.Writer.Static.Shared (Writer, tell)+import Prelude hiding (map, mapM)+++-- | Effect for publishing events of type @event@.+data Pub (event :: Type) :: Effect where+ -- | Publish an event to all current subscribers.+ Publish :: event -> Pub event m ()+++makeEffect ''Pub+++runNoOp :: forall event es a. Eff (Pub event : es) a -> Eff es a+runNoOp = interpret_ \(Publish _) -> pure ()+++-- | Handler that uses a provided Writer effect instead of actually publishing.+-- Useful for testing and inspecting what events were published.+toWriter :: forall event es a. (Writer [event] :> es) => Eff (Pub event : es) a -> Eff es a+toWriter =+ interpret_ \case+ Publish event -> tell [event]+++-- | Convert published events of one type into another, utilizing an existing+-- effect in the effect stack.+map :: forall e1 e2 es a. (Pub e2 :> es) => (e1 -> e2) -> Eff (Pub e1 : es) a -> Eff es a+map f = interpret_ \(Publish event) -> publish $ f event+++-- | Convert published events of one type into another with an effectful+-- transformation, utilizing an existing effect int he effect stack.+mapM :: forall e1 e2 es a. (Pub e2 :> es) => (e1 -> Eff es e2) -> Eff (Pub e1 : es) a -> Eff es a+mapM f = interpret_ \(Publish event) -> f event >>= publish+++-- | Perform an effectful action for each published event.+consume :: (event -> Eff es ()) -> Eff (Pub event : es) a -> Eff es a+consume handler = interpret_ \case+ Publish event -> handler event
+ src/Atelier/Effects/PubSub/Sub.hs view
@@ -0,0 +1,155 @@+module Atelier.Effects.PubSub.Sub+ ( Sub (..)+ , listen+ , listen_+ , listenWith+ , listenWith_+ , listenOnce+ , listenOnce_+ , listenUntil+ , listenUntil_+ , listenUntilM+ , listenUntilM_+ , forkListener+ , forkListener_+ )+where++import Data.Time (UTCTime)+import Effectful (Effect, inject)+import Effectful.Concurrent.STM+ ( Concurrent+ , atomically+ , newEmptyTMVar+ , putTMVar+ , takeTMVar+ )+import Effectful.Error.Static (runErrorNoCallStack, throwError)+import Effectful.TH (makeEffect)++import Text.Show qualified as S++import Atelier.Effects.Conc (Conc, fork_)+++-- | Effect for subscribing to events of type @event@.+data Sub (event :: Type) :: Effect where+ -- | Subscribe, then run @onSubscribed@ once the subscription is established+ -- — after the internal channel has been duplicated and before any event is+ -- delivered — and thereafter deliver every published event to the listener,+ -- forever. The @onSubscribed@ hook lets a caller synchronize on "subscribed"+ -- so a concurrently-started publisher cannot race ahead of the subscription+ -- and have its events missed. Most callers want 'listen' (no hook); a caller+ -- that forks the listener and then publishes must wait on this hook first.+ ListenWith+ :: m ()+ -- ^ @onSubscribed@ hook to better synchronize on "subscribed".+ -> (UTCTime -> event -> m ())+ -- ^ Listener function to react to events.+ -> Sub event m Void+++makeEffect ''Sub+++-- | Subscribe and deliver every published event to the listener, forever.+-- Defined in terms of 'listenWith' with a no-op subscribed hook.+listen :: (Sub event :> es) => (UTCTime -> event -> Eff es ()) -> Eff es Void+listen = listenWith (pure ())+++-- | Like 'listen', but the listener ignores the event timestamp.+listen_ :: (Sub event :> es) => (event -> Eff es ()) -> Eff es Void+listen_ listener = listen $ \_timestamp event -> listener event+++-- | Like 'listen_', but runs @onSubscribed@ once the subscription is+-- established and before any event is delivered. See 'ListenWith'.+listenWith_ :: (Sub event :> es) => Eff es () -> (event -> Eff es ()) -> Eff es Void+listenWith_ onSubscribed listener = listenWith onSubscribed $ \_timestamp event -> listener event+++-- | Listens until the passed function returns @Just a@, returning said @a@+-- with a timestamp.+listenUntil :: (Sub event :> es) => (UTCTime -> event -> Maybe a) -> Eff es (UTCTime, a)+listenUntil f = do+ res <- runErrorNoCallStack+ $ listen+ $ \timestamp event -> whenJust (f timestamp event) \a -> do+ throwError $ OnceEx (timestamp, a)+ case res of+ Left (OnceEx x) -> pure x+ Right v -> absurd v+++listenUntil_ :: (Sub event :> es) => (event -> Maybe a) -> Eff es a+listenUntil_ f = snd <$> listenUntil (\_ -> f)+++-- | Listens until the passed event handler returns @Just a@, returning said+-- @a@ with a timestamp.+listenUntilM :: (Sub event :> es) => (UTCTime -> event -> Eff es (Maybe a)) -> Eff es (UTCTime, a)+listenUntilM f = do+ res <- runErrorNoCallStack+ $ listen+ $ \timestamp event -> whenJustM (inject $ f timestamp event) \a -> do+ throwError $ OnceEx (timestamp, a)+ case res of+ Left (OnceEx x) -> pure x+ Right v -> absurd v+++-- | Listens until the passed event handler returns @Just a@, returning said+-- @a@.+listenUntilM_ :: (Sub event :> es) => (event -> Eff es (Maybe a)) -> Eff es a+listenUntilM_ f = snd <$> listenUntilM (\_ -> f)+++-- | Fork a background listener and block until it has actually subscribed,+-- then return. The listener runs until the enclosing 'Conc' scope closes.+--+-- This is the safe way to start a listener you intend to publish to: a plain+-- @'fork_' . 'listen'@ followed by a 'publish' races the subscription (which+-- happens asynchronously in the forked thread) and, under scheduler pressure,+-- can drop early events and wedge the listener forever. 'forkListener' closes+-- that window by waiting on the subscribed hook before returning.+forkListener+ :: forall event es+ . (Conc :> es, Concurrent :> es, Sub event :> es)+ => (UTCTime -> event -> Eff es ())+ -> Eff es ()+forkListener listener = do+ subscribed <- atomically newEmptyTMVar+ fork_ $ listenWith (atomically (putTMVar subscribed ())) listener+ atomically (takeTMVar subscribed)+++-- | Like 'forkListener', but the listener ignores the timestamp.+forkListener_+ :: forall event es+ . (Conc :> es, Concurrent :> es, Sub event :> es)+ => (event -> Eff es ())+ -> Eff es ()+forkListener_ listener = forkListener @event (\_timestamp event -> listener event)+++-- | Wait for a single event and then return said event.+listenOnce :: forall event es. (Sub event :> es) => Eff es (UTCTime, event)+listenOnce = do+ res <- runErrorNoCallStack+ $ listen+ $ \timestamp event -> throwError $ OnceEx (timestamp, event)+ case res of+ Left (OnceEx x) -> pure x+ Right v -> absurd v+++-- | Same as 'listenOnce', but discards the timestamp.+listenOnce_ :: (Sub event :> es) => Eff es event+listenOnce_ = snd <$> listenOnce+++data OnceEx ev = OnceEx ev+++instance Show (OnceEx ev) where show _ = "OnceEx"
src/Atelier/Effects/Publishing.hs view
@@ -1,18 +1,11 @@-module Atelier.Effects.Publishing- ( runPubSub- )-where--import Data.Time (UTCTime)-import Effectful.Dispatch.Dynamic (interpret, interpret_, localSeqUnlift)+module Atelier.Effects.Publishing (runPubSub) where import Atelier.Effects.Chan (Chan) import Atelier.Effects.Clock (Clock)-import Atelier.Effects.Publishing.Pub (Pub (..))-import Atelier.Effects.Publishing.Sub (Sub (..))+import Atelier.Effects.PubSub.Pub (Pub)+import Atelier.Effects.PubSub.Sub (Sub) -import Atelier.Effects.Chan qualified as Chan-import Atelier.Effects.Clock qualified as Clock+import Atelier.Effects.PubSub qualified as PubSub -- | Runs 'Pub' and 'Sub' effects with an internal channel for a specific event@@ -21,19 +14,5 @@ :: forall event es a . (Chan :> es, Clock :> es) => Eff (Pub event : Sub event : es) a -> Eff es a-runPubSub action = do- (inChan, _) <- Chan.newChan @(UTCTime, event)- let handlePub = interpret_ \case- Publish event -> do- timestamp <- Clock.currentTime- Chan.writeChan inChan (timestamp, event)-- handleSub = interpret \env -> \case- ListenWith onSubscribed listener -> localSeqUnlift env \unlift -> do- chan <- Chan.dupChan inChan- unlift onSubscribed- forever do- (timestamp, event) <- Chan.readChan chan- unlift $ listener timestamp event-- handleSub . handlePub $ action+runPubSub = PubSub.run+{-# DEPRECATED runPubSub "Use 'Atelier.Effects.PubSub.run' instead." #-}
src/Atelier/Effects/Publishing/Pub.hs view
@@ -1,58 +1,8 @@ module Atelier.Effects.Publishing.Pub- ( -- * Effect- Pub (..)- , publish-- -- * Interpeters- , runNoOp- , toWriter- , map- , mapM- , consume+ {-# DEPRECATED "Use 'Atelier.Effects.PubSub.Pub' instead." #-}+ ( module Pub ) where -import Effectful (Effect)-import Effectful.Dispatch.Dynamic (interpret_)-import Effectful.TH (makeEffect)-import Effectful.Writer.Static.Shared (Writer, tell)-import Prelude hiding (map, mapM)----- | Effect for publishing events of type @event@.-data Pub (event :: Type) :: Effect where- -- | Publish an event to all current subscribers.- Publish :: event -> Pub event m ()---makeEffect ''Pub---runNoOp :: forall event es a. Eff (Pub event : es) a -> Eff es a-runNoOp = interpret_ \(Publish _) -> pure ()----- | Handler that uses a provided Writer effect instead of actually publishing.--- Useful for testing and inspecting what events were published.-toWriter :: forall event es a. (Writer [event] :> es) => Eff (Pub event : es) a -> Eff es a-toWriter =- interpret_ \case- Publish event -> tell [event]----- | Convert published events of one type into another, utilizing an existing--- effect in the effect stack.-map :: forall e1 e2 es a. (Pub e2 :> es) => (e1 -> e2) -> Eff (Pub e1 : es) a -> Eff es a-map f = interpret_ \(Publish event) -> publish $ f event----- | Convert published events of one type into another with an effectful--- transformation, utilizing an existing effect int he effect stack.-mapM :: forall e1 e2 es a. (Pub e2 :> es) => (e1 -> Eff es e2) -> Eff (Pub e1 : es) a -> Eff es a-mapM f = interpret_ \(Publish event) -> f event >>= publish-+import Atelier.Effects.PubSub.Pub as Pub --- | Perform an effectful action for each published event.-consume :: (event -> Eff es ()) -> Eff (Pub event : es) a -> Eff es a-consume handler = interpret_ \case- Publish event -> handler event
src/Atelier/Effects/Publishing/Sub.hs view
@@ -1,155 +1,8 @@ module Atelier.Effects.Publishing.Sub- ( Sub (..)- , listen- , listen_- , listenWith- , listenWith_- , listenOnce- , listenOnce_- , listenUntil- , listenUntil_- , listenUntilM- , listenUntilM_- , forkListener- , forkListener_+ {-# DEPRECATED "Use 'Atelier.Effects.PubSub.Sub' instead." #-}+ ( module Sub ) where -import Data.Time (UTCTime)-import Effectful (Effect, inject)-import Effectful.Concurrent.STM- ( Concurrent- , atomically- , newEmptyTMVar- , putTMVar- , takeTMVar- )-import Effectful.Error.Static (runErrorNoCallStack, throwError)-import Effectful.TH (makeEffect)--import Text.Show qualified as S--import Atelier.Effects.Conc (Conc, fork_)----- | Effect for subscribing to events of type @event@.-data Sub (event :: Type) :: Effect where- -- | Subscribe, then run @onSubscribed@ once the subscription is established- -- — after the internal channel has been duplicated and before any event is- -- delivered — and thereafter deliver every published event to the listener,- -- forever. The @onSubscribed@ hook lets a caller synchronize on "subscribed"- -- so a concurrently-started publisher cannot race ahead of the subscription- -- and have its events missed. Most callers want 'listen' (no hook); a caller- -- that forks the listener and then publishes must wait on this hook first.- ListenWith- :: m ()- -- ^ @onSubscribed@ hook to better synchronize on "subscribed".- -> (UTCTime -> event -> m ())- -- ^ Listener function to react to events.- -> Sub event m Void---makeEffect ''Sub----- | Subscribe and deliver every published event to the listener, forever.--- Defined in terms of 'listenWith' with a no-op subscribed hook.-listen :: (Sub event :> es) => (UTCTime -> event -> Eff es ()) -> Eff es Void-listen = listenWith (pure ())----- | Like 'listen', but the listener ignores the event timestamp.-listen_ :: (Sub event :> es) => (event -> Eff es ()) -> Eff es Void-listen_ listener = listen $ \_timestamp event -> listener event----- | Like 'listen_', but runs @onSubscribed@ once the subscription is--- established and before any event is delivered. See 'ListenWith'.-listenWith_ :: (Sub event :> es) => Eff es () -> (event -> Eff es ()) -> Eff es Void-listenWith_ onSubscribed listener = listenWith onSubscribed $ \_timestamp event -> listener event----- | Listens until the passed function returns @Just a@, returning said @a@--- with a timestamp.-listenUntil :: (Sub event :> es) => (UTCTime -> event -> Maybe a) -> Eff es (UTCTime, a)-listenUntil f = do- res <- runErrorNoCallStack- $ listen- $ \timestamp event -> whenJust (f timestamp event) \a -> do- throwError $ OnceEx (timestamp, a)- case res of- Left (OnceEx x) -> pure x- Right v -> absurd v---listenUntil_ :: (Sub event :> es) => (event -> Maybe a) -> Eff es a-listenUntil_ f = snd <$> listenUntil (\_ -> f)----- | Listens until the passed event handler returns @Just a@, returning said--- @a@ with a timestamp.-listenUntilM :: (Sub event :> es) => (UTCTime -> event -> Eff es (Maybe a)) -> Eff es (UTCTime, a)-listenUntilM f = do- res <- runErrorNoCallStack- $ listen- $ \timestamp event -> whenJustM (inject $ f timestamp event) \a -> do- throwError $ OnceEx (timestamp, a)- case res of- Left (OnceEx x) -> pure x- Right v -> absurd v----- | Listens until the passed event handler returns @Just a@, returning said--- @a@.-listenUntilM_ :: (Sub event :> es) => (event -> Eff es (Maybe a)) -> Eff es a-listenUntilM_ f = snd <$> listenUntilM (\_ -> f)----- | Fork a background listener and block until it has actually subscribed,--- then return. The listener runs until the enclosing 'Conc' scope closes.------ This is the safe way to start a listener you intend to publish to: a plain--- @'fork_' . 'listen'@ followed by a 'publish' races the subscription (which--- happens asynchronously in the forked thread) and, under scheduler pressure,--- can drop early events and wedge the listener forever. 'forkListener' closes--- that window by waiting on the subscribed hook before returning.-forkListener- :: forall event es- . (Conc :> es, Concurrent :> es, Sub event :> es)- => (UTCTime -> event -> Eff es ())- -> Eff es ()-forkListener listener = do- subscribed <- atomically newEmptyTMVar- fork_ $ listenWith (atomically (putTMVar subscribed ())) listener- atomically (takeTMVar subscribed)----- | Like 'forkListener', but the listener ignores the timestamp.-forkListener_- :: forall event es- . (Conc :> es, Concurrent :> es, Sub event :> es)- => (event -> Eff es ())- -> Eff es ()-forkListener_ listener = forkListener @event (\_timestamp event -> listener event)----- | Wait for a single event and then return said event.-listenOnce :: forall event es. (Sub event :> es) => Eff es (UTCTime, event)-listenOnce = do- res <- runErrorNoCallStack- $ listen- $ \timestamp event -> throwError $ OnceEx (timestamp, event)- case res of- Left (OnceEx x) -> pure x- Right v -> absurd v----- | Same as 'listenOnce', but discards the timestamp.-listenOnce_ :: (Sub event :> es) => Eff es event-listenOnce_ = snd <$> listenOnce---data OnceEx ev = OnceEx ev-+import Atelier.Effects.PubSub.Sub as Sub -instance Show (OnceEx ev) where show _ = "OnceEx"
+ src/Atelier/Effects/Reader.hs view
@@ -0,0 +1,13 @@+module Atelier.Effects.Reader (project) where++import Effectful.Reader.Static (Reader)++import Effectful.Reader.Static qualified as Reader+++-- | Use the value from an existing 'Reader' effect to interpret another+-- 'Reader' effect.+project :: (Reader a :> es) => (a -> b) -> Eff (Reader b : es) x -> Eff es x+project f act = do+ b <- f <$> Reader.ask+ Reader.runReader b act
+ src/Atelier/Types/JSON/QuietSnake.hs view
@@ -0,0 +1,59 @@+{-# LANGUAGE UndecidableInstances #-}++-- | Derive 'FromJSON' and 'ToJSON' for a record so its Haskell field names map+-- to @quiet_snake_case@ JSON keys.+--+-- \"Quiet\" snake case lowercases and underscore-separates words without an+-- extra leading underscore, so the field @maxRetries@ becomes the JSON key+-- @max_retries@. Derive via this wrapper to keep idiomatic Haskell field names+-- while exposing snake-case JSON:+--+-- @+-- data Settings = Settings { maxRetries :: Int, dryRun :: Bool }+-- deriving stock (Generic)+-- deriving (FromJSON, ToJSON) via (QuietSnake Settings)+-- @+module Atelier.Types.JSON.QuietSnake+ ( QuietSnake (..)+ , options+ )+where++import Data.Aeson+ ( FromJSON (..)+ , GFromJSON+ , GToJSON+ , Options (..)+ , ToJSON (..)+ , Zero+ , camelTo2+ , defaultOptions+ , genericParseJSON+ , genericToJSON+ )+import Data.Default (Default (..))+import GHC.Generics (Rep)+++-- | Carrier for deriving @quiet_snake_case@ JSON instances generically.+newtype QuietSnake a = QuietSnake {getQuietSnake :: a}+++instance (Default a) => Default (QuietSnake a) where+ def = QuietSnake def+++instance (GFromJSON Zero (Rep a), Generic a) => FromJSON (QuietSnake a) where+ parseJSON = fmap QuietSnake . genericParseJSON options+++instance (GToJSON Zero (Rep a), Generic a) => ToJSON (QuietSnake a) where+ toJSON = genericToJSON options . getQuietSnake+++options :: Options+options =+ defaultOptions+ { constructorTagModifier = camelTo2 '_'+ , fieldLabelModifier = camelTo2 '_'+ }
+ src/Atelier/Types/JSON/ReadShow.hs view
@@ -0,0 +1,38 @@+module Atelier.Types.JSON.ReadShow (ReadShow (..)) where++import Data.Aeson (FromJSON (..), ToJSON (..), Value (..), withText)+import Data.Typeable (typeRep)+++-- | Derive 'FromJSON' and 'ToJSON' for a type from its 'Read' and 'Show'+-- instances, encoding each value as a JSON string.+--+-- A value is stored as its 'Show' output and parsed back with 'readMaybe'. On+-- failure the error message names the type (via 'Typeable'), e.g.+-- @Failed to read Mode@.+--+-- @+-- data Mode = Fast | Slow+-- deriving stock (Read, Show)+-- deriving (FromJSON, ToJSON) via (ReadShow Mode)+-- @+--+-- Here @Fast@ serialises to the JSON string @\"Fast\"@.+newtype ReadShow a = ReadShow {getReadShow :: a}+++instance forall a. (Read a, Typeable a) => FromJSON (ReadShow a) where+ parseJSON =+ let+ typeName = show $ typeRep $ Proxy @a+ in+ withText typeName+ $ maybe+ (fail $ "Failed to read " <> typeName)+ (pure . ReadShow)+ . readMaybe+ . toString+++instance (Show a) => ToJSON (ReadShow a) where+ toJSON = String . show . getReadShow
+ src/Atelier/Types/JSON/StringLiteral.hs view
@@ -0,0 +1,29 @@+module Atelier.Types.JSON.StringLiteral (StringLiteral (..)) where++import Data.Aeson (FromJSON (..), ToJSON (..), withText)+import Data.Default (Default (..))+import GHC.TypeLits (KnownSymbol, Symbol, symbolVal)+++-- | Parses and encodes to a specific string literal.+--+-- For parsing, if the parsed JSON value matches the specified string literal,+-- the 'Default' value of the type is returned. All other JSON values are+-- considered invalid.+--+-- This is useful for types consisting of a single nullary constructor that you+-- want to encode as a specific string (that is different from the 'Show' and+-- 'Read' instances of the constructor.)+newtype StringLiteral (literal :: Symbol) a = StringLiteral {getStringLiteral :: a}+++instance forall lit a. (Default a, KnownSymbol lit) => FromJSON (StringLiteral lit a) where+ parseJSON = withText "StringLiteral" \t ->+ if t == toText (symbolVal (Proxy :: Proxy lit))+ then pure $ StringLiteral def+ else fail $ "unexpected value of string. expected " <> symbolVal (Proxy :: Proxy lit)+++instance forall lit a. (KnownSymbol lit) => ToJSON (StringLiteral lit a) where+ toJSON _ = toJSON $ symbolVal (Proxy :: Proxy lit)+ toEncoding _ = toEncoding $ symbolVal (Proxy :: Proxy lit)
src/Atelier/Types/JsonReadShow.hs view
@@ -1,39 +1,12 @@--- | Derive 'FromJSON' and 'ToJSON' for a type from its 'Read' and 'Show'--- instances, encoding each value as a JSON string.------ A value is stored as its 'Show' output and parsed back with 'readMaybe'. On--- failure the error message names the type (via 'Typeable'), e.g.--- @Failed to read Mode@.------ @--- data Mode = Fast | Slow--- deriving stock (Read, Show)--- deriving (FromJSON, ToJSON) via (JsonReadShow Mode)--- @------ Here @Fast@ serialises to the JSON string @\"Fast\"@.-module Atelier.Types.JsonReadShow (JsonReadShow (..)) where--import Data.Aeson (FromJSON (..), ToJSON (..), Value (..), withText)-import Data.Typeable (typeRep)----- | Carrier for deriving JSON instances via 'Read' and 'Show'.-newtype JsonReadShow a = JsonReadShow {getJsonReadShow :: a}+module Atelier.Types.JsonReadShow+ {-# DEPRECATED "Use Atelier.Types.JSON.ReadShow instead" #-}+ (JsonReadShow (..))+where +import Data.Aeson (FromJSON, ToJSON) -instance forall a. (Read a, Typeable a) => FromJSON (JsonReadShow a) where- parseJSON =- let- typeName = show $ typeRep $ Proxy @a- in- withText typeName- $ maybe- (fail $ "Failed to read " <> typeName)- (pure . JsonReadShow)- . readMaybe- . toString+import Atelier.Types.JSON.ReadShow (ReadShow (..)) -instance (Show a) => ToJSON (JsonReadShow a) where- toJSON = String . show . getJsonReadShow+newtype JsonReadShow a = JsonReadShow {getJsonReadShow :: a}+ deriving (FromJSON, ToJSON) via ReadShow a
src/Atelier/Types/QuietSnake.hs view
@@ -1,54 +1,8 @@-{-# LANGUAGE UndecidableInstances #-}---- | Derive 'FromJSON' and 'ToJSON' for a record so its Haskell field names map--- to @quiet_snake_case@ JSON keys.------ \"Quiet\" snake case lowercases and underscore-separates words without an--- extra leading underscore, so the field @maxRetries@ becomes the JSON key--- @max_retries@. Derive via this wrapper to keep idiomatic Haskell field names--- while exposing snake-case JSON:------ @--- data Settings = Settings { maxRetries :: Int, dryRun :: Bool }--- deriving stock (Generic)--- deriving (FromJSON, ToJSON) via (QuietSnake Settings)--- @ module Atelier.Types.QuietSnake+ {-# DEPRECATED "Renamed to Atelier.Types.JSON.QuietSnake" #-} ( QuietSnake (..) ) where -import Data.Aeson- ( FromJSON (..)- , GFromJSON- , GToJSON- , Options- , ToJSON (..)- , Zero- , genericParseJSON- , genericToJSON- )-import Data.Aeson.Types (defaultOptions, fieldLabelModifier)-import Data.Default (Default (..))-import GHC.Generics (Rep)-import Text.Casing (quietSnake)----- | Carrier for deriving @quiet_snake_case@ JSON instances generically.-newtype QuietSnake a = QuietSnake {getQuietSnake :: a}---instance (Default a) => Default (QuietSnake a) where- def = QuietSnake def---instance (GFromJSON Zero (Rep a), Generic a) => FromJSON (QuietSnake a) where- parseJSON = fmap QuietSnake . genericParseJSON opts---instance (GToJSON Zero (Rep a), Generic a) => ToJSON (QuietSnake a) where- toJSON = genericToJSON opts . getQuietSnake-+import Atelier.Types.JSON.QuietSnake (QuietSnake (..)) -opts :: Options-opts = defaultOptions {fieldLabelModifier = quietSnake}
test/Unit/Atelier/ConfigSpec.hs view
@@ -10,7 +10,7 @@ import Data.Aeson.KeyMap qualified as KM import Atelier.Config (LoadedConfig (..), extractNestedConfig)-import Atelier.Types.QuietSnake (QuietSnake (..))+import Atelier.Types.JSON.QuietSnake (QuietSnake (..)) import Atelier.Types.WithDefaults (WithDefaults (..))
test/Unit/Atelier/Effects/Conc/TeardownStressSpec.hs view
@@ -28,12 +28,12 @@ import Atelier.Effects.Chan (Chan, runChan) import Atelier.Effects.Clock (Clock, runClock) import Atelier.Effects.Conc (Conc, fork, fork_, runConc, scoped)-import Atelier.Effects.Publishing (runPubSub)-import Atelier.Effects.Publishing.Pub (Pub)-import Atelier.Effects.Publishing.Sub (Sub)+import Atelier.Effects.PubSub.Pub (Pub)+import Atelier.Effects.PubSub.Sub (Sub) import Atelier.Effects.Iterator qualified as Iter-import Atelier.Effects.Publishing.Pub qualified as Pub+import Atelier.Effects.PubSub qualified as PubSub+import Atelier.Effects.PubSub.Pub qualified as Pub test_ConcTeardownStress :: IO TestTree@@ -133,4 +133,4 @@ -- | Mirrors 'IteratorSpec.runTest' — the full effect stack the real victim runs on. runIterTest :: Eff '[Pub Int, Sub Int, Chan, Clock, Conc, Concurrent, IOE] a -> IO a-runIterTest = runEff . runConcurrent . runConc . runClock . runChan . runPubSub @Int+runIterTest = runEff . runConcurrent . runConc . runClock . runChan . PubSub.run @Int
test/Unit/Atelier/Effects/IteratorSpec.hs view
@@ -9,12 +9,12 @@ import Atelier.Effects.Chan (Chan, runChan) import Atelier.Effects.Clock (Clock, runClock) import Atelier.Effects.Conc (Conc, fork, runConc)-import Atelier.Effects.Publishing (runPubSub)-import Atelier.Effects.Publishing.Pub (Pub)-import Atelier.Effects.Publishing.Sub (Sub)+import Atelier.Effects.PubSub.Pub (Pub)+import Atelier.Effects.PubSub.Sub (Sub) import Atelier.Effects.Iterator qualified as Iter-import Atelier.Effects.Publishing.Pub qualified as Pub+import Atelier.Effects.PubSub qualified as PubSub+import Atelier.Effects.PubSub.Pub qualified as Pub test_Iterator :: TestTree@@ -118,4 +118,4 @@ . runConc . runClock . runChan- . runPubSub @Int+ . PubSub.run @Int
+ test/Unit/Atelier/Effects/PubSub/PubSpec.hs view
@@ -0,0 +1,62 @@+module Unit.Atelier.Effects.PubSub.PubSpec (test_Pub) where++import Effectful (runPureEff)+import Effectful.Writer.Static.Shared (execWriter)+import Test.Tasty (TestTree, testGroup)+import Test.Tasty.HUnit (testCase, (@?=))++import Atelier.Effects.PubSub.Pub qualified as Pub+++data TestEvent = TestEvent Text+ deriving stock (Eq, Show)+++test_Pub :: TestTree+test_Pub =+ testGroup+ "Pub"+ [ testGroup+ "toWriter"+ [ testGroup+ "no events published"+ [ testCase "doesn't record events" do+ let events =+ runPureEff . execWriter . Pub.toWriter @TestEvent+ $ pure ()++ events @?= []+ ]+ , testGroup+ "events published"+ [ testCase "records events" do+ let events =+ runPureEff . execWriter . Pub.toWriter @TestEvent $ do+ Pub.publish $ TestEvent "payload"+ pure ()++ events @?= [TestEvent "payload"]+ ]+ ]+ , testGroup+ "map"+ [ testCase "maps over one event" do+ let events =+ runPureEff+ . execWriter+ . Pub.toWriter @Text+ . Pub.map show+ $ Pub.publish @Int 1++ events @?= ["1"]+ , testCase "maps over many events" do+ let events =+ runPureEff+ . execWriter+ . Pub.toWriter @Text+ . Pub.map show+ $ traverse Pub.publish [1 .. 10 :: Int]++ events @?= ["1", "2", "3", "4", "5", "6", "7", "8", "9", "10"]+ ]+ ]
+ test/Unit/Atelier/Effects/PubSubSpec.hs view
@@ -0,0 +1,89 @@+module Unit.Atelier.Effects.PubSubSpec (test_PubSub) where++import Control.Concurrent.MVar (newEmptyMVar, putMVar, takeMVar)+import Data.Time (UTCTime, getCurrentTime)+import Effectful (IOE, runEff)+import Effectful.Concurrent (Concurrent, runConcurrent)+import Test.Tasty (TestTree, testGroup)+import Test.Tasty.HUnit (testCase, (@?=))++import Atelier.Effects.Chan (Chan, runChan)+import Atelier.Effects.Clock (Clock, runClock, runClockConst)+import Atelier.Effects.Conc (Conc, runConc)+import Atelier.Effects.PubSub.Pub (Pub)+import Atelier.Effects.PubSub.Sub (Sub)++import Atelier.Effects.PubSub qualified as PubSub+import Atelier.Effects.PubSub.Pub qualified as Pub+import Atelier.Effects.PubSub.Sub qualified as Sub+++data TestEvent = TestEvent Text+ deriving stock (Eq, Show)+++test_PubSub :: TestTree+test_PubSub =+ testGroup+ "PubSub"+ [ testGroup+ "run"+ [ testCase "listener receives a published event" do+ result <- runPubSubTest $ do+ received <- liftIO newEmptyMVar+ Sub.forkListener_ @TestEvent \event ->+ liftIO $ putMVar received event+ Pub.publish (TestEvent "hello")+ liftIO $ takeMVar received+ result @?= TestEvent "hello"+ , testCase "event timestamp matches Clock at publish time" do+ t0 <- getCurrentTime+ result <- runPubSubTestWithClock t0 $ do+ received <- liftIO newEmptyMVar+ Sub.forkListener @TestEvent \ts _event ->+ liftIO $ putMVar received ts+ Pub.publish (TestEvent "hello")+ liftIO $ takeMVar received+ result @?= t0+ , testCase "multiple listeners each receive the published event" do+ result <- runPubSubTest $ do+ recv1 <- liftIO newEmptyMVar+ recv2 <- liftIO newEmptyMVar+ Sub.forkListener_ @TestEvent \event -> liftIO $ putMVar recv1 event+ Sub.forkListener_ @TestEvent \event -> liftIO $ putMVar recv2 event+ Pub.publish (TestEvent "hello")+ e1 <- liftIO $ takeMVar recv1+ e2 <- liftIO $ takeMVar recv2+ pure (e1, e2)+ result @?= (TestEvent "hello", TestEvent "hello")+ ]+ ]+++--------------------------------------------------------------------------------+-- Test Helpers+--------------------------------------------------------------------------------++runPubSubTest+ :: Eff '[Pub TestEvent, Sub TestEvent, Chan, Clock, Conc, Concurrent, IOE] a+ -> IO a+runPubSubTest =+ runEff+ . runConcurrent+ . runConc+ . runClock+ . runChan+ . PubSub.run @TestEvent+++runPubSubTestWithClock+ :: UTCTime+ -> Eff '[Pub TestEvent, Sub TestEvent, Chan, Clock, Conc, Concurrent, IOE] a+ -> IO a+runPubSubTestWithClock t =+ runEff+ . runConcurrent+ . runConc+ . runClockConst t+ . runChan+ . PubSub.run @TestEvent
− test/Unit/Atelier/Effects/Publishing/PubSpec.hs
@@ -1,62 +0,0 @@-module Unit.Atelier.Effects.Publishing.PubSpec (test_Pub) where--import Effectful (runPureEff)-import Effectful.Writer.Static.Shared (execWriter)-import Test.Tasty (TestTree, testGroup)-import Test.Tasty.HUnit (testCase, (@?=))--import Atelier.Effects.Publishing.Pub qualified as Pub---data TestEvent = TestEvent Text- deriving stock (Eq, Show)---test_Pub :: TestTree-test_Pub =- testGroup- "Pub"- [ testGroup- "toWriter"- [ testGroup- "no events published"- [ testCase "doesn't record events" do- let events =- runPureEff . execWriter . Pub.toWriter @TestEvent- $ pure ()-- events @?= []- ]- , testGroup- "events published"- [ testCase "records events" do- let events =- runPureEff . execWriter . Pub.toWriter @TestEvent $ do- Pub.publish $ TestEvent "payload"- pure ()-- events @?= [TestEvent "payload"]- ]- ]- , testGroup- "map"- [ testCase "maps over one event" do- let events =- runPureEff- . execWriter- . Pub.toWriter @Text- . Pub.map show- $ Pub.publish @Int 1-- events @?= ["1"]- , testCase "maps over many events" do- let events =- runPureEff- . execWriter- . Pub.toWriter @Text- . Pub.map show- $ traverse Pub.publish [1 .. 10 :: Int]-- events @?= ["1", "2", "3", "4", "5", "6", "7", "8", "9", "10"]- ]- ]
− test/Unit/Atelier/Effects/PublishingSpec.hs
@@ -1,89 +0,0 @@-module Unit.Atelier.Effects.PublishingSpec (test_Publishing) where--import Control.Concurrent.MVar (newEmptyMVar, putMVar, takeMVar)-import Data.Time (UTCTime, getCurrentTime)-import Effectful (IOE, runEff)-import Effectful.Concurrent (Concurrent, runConcurrent)-import Test.Tasty (TestTree, testGroup)-import Test.Tasty.HUnit (testCase, (@?=))--import Atelier.Effects.Chan (Chan, runChan)-import Atelier.Effects.Clock (Clock, runClock, runClockConst)-import Atelier.Effects.Conc (Conc, runConc)-import Atelier.Effects.Publishing (runPubSub)-import Atelier.Effects.Publishing.Pub (Pub)-import Atelier.Effects.Publishing.Sub (Sub)--import Atelier.Effects.Publishing.Pub qualified as Pub-import Atelier.Effects.Publishing.Sub qualified as Sub---data TestEvent = TestEvent Text- deriving stock (Eq, Show)---test_Publishing :: TestTree-test_Publishing =- testGroup- "Publishing"- [ testGroup- "runPubSub"- [ testCase "listener receives a published event" do- result <- runPubSubTest $ do- received <- liftIO newEmptyMVar- Sub.forkListener_ @TestEvent \event ->- liftIO $ putMVar received event- Pub.publish (TestEvent "hello")- liftIO $ takeMVar received- result @?= TestEvent "hello"- , testCase "event timestamp matches Clock at publish time" do- t0 <- getCurrentTime- result <- runPubSubTestWithClock t0 $ do- received <- liftIO newEmptyMVar- Sub.forkListener @TestEvent \ts _event ->- liftIO $ putMVar received ts- Pub.publish (TestEvent "hello")- liftIO $ takeMVar received- result @?= t0- , testCase "multiple listeners each receive the published event" do- result <- runPubSubTest $ do- recv1 <- liftIO newEmptyMVar- recv2 <- liftIO newEmptyMVar- Sub.forkListener_ @TestEvent \event -> liftIO $ putMVar recv1 event- Sub.forkListener_ @TestEvent \event -> liftIO $ putMVar recv2 event- Pub.publish (TestEvent "hello")- e1 <- liftIO $ takeMVar recv1- e2 <- liftIO $ takeMVar recv2- pure (e1, e2)- result @?= (TestEvent "hello", TestEvent "hello")- ]- ]-------------------------------------------------------------------------------------- Test Helpers-----------------------------------------------------------------------------------runPubSubTest- :: Eff '[Pub TestEvent, Sub TestEvent, Chan, Clock, Conc, Concurrent, IOE] a- -> IO a-runPubSubTest =- runEff- . runConcurrent- . runConc- . runClock- . runChan- . runPubSub @TestEvent---runPubSubTestWithClock- :: UTCTime- -> Eff '[Pub TestEvent, Sub TestEvent, Chan, Clock, Conc, Concurrent, IOE] a- -> IO a-runPubSubTestWithClock t =- runEff- . runConcurrent- . runConc- . runClockConst t- . runChan- . runPubSub @TestEvent
test/Unit/Atelier/Types/WithDefaultsSpec.hs view
@@ -7,7 +7,7 @@ import Data.ByteString.Lazy qualified as LBS -import Atelier.Types.QuietSnake (QuietSnake (..))+import Atelier.Types.JSON.QuietSnake (QuietSnake (..)) import Atelier.Types.WithDefaults (WithDefaults (..))