packages feed

atelier-core (empty) → 0.1.0.0

raw patch · 70 files changed

+7433/−0 lines, 70 filesdep +aesondep +asyncdep +atelier-core

Dependencies added: aeson, async, atelier-core, atelier-prelude, base, base64-bytestring, bytestring, casing, containers, contra-tracer, daemons, data-default, directory, effectful, effectful-core, effectful-plugin, effectful-th, filepath, fsnotify, hedgehog, hs-opentelemetry-api, hs-opentelemetry-exporter-otlp, hs-opentelemetry-sdk, hspec, hspec-hedgehog, http-api-data, http-types, ki, list-t, optparse-applicative, process, prometheus-client, prometheus-metrics-ghc, stm, stm-containers, tasty, tasty-hspec, text, time, time-units, typed-process, unagi-chan, unix, unordered-containers, uuid, wai, warp

Files

+ CHANGELOG.md view
@@ -0,0 +1,13 @@+# Changelog++All notable changes to `atelier-core` will be documented in this file.++The format is based on [Keep a Changelog](https://keepachangelog.com/en/1.1.0/),+and this project adheres to the [PVP](https://pvp.haskell.org/).++## [Unreleased]++### Added++- Initial release: foundational Effectful-based effects and utilities,+  extracted from the atelier toolkit.
+ LICENSE view
@@ -0,0 +1,21 @@+MIT License++Copyright (c) 2025 Christian Georgii++Permission is hereby granted, free of charge, to any person obtaining a copy+of this software and associated documentation files (the "Software"), to deal+in the Software without restriction, including without limitation the rights+to use, copy, modify, merge, publish, distribute, sublicense, and/or sell+copies of the Software, and to permit persons to whom the Software is+furnished to do so, subject to the following conditions:++The above copyright notice and this permission notice shall be included in all+copies or substantial portions of the Software.++THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR+IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY,+FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE+AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER+LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM,+OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE+SOFTWARE.
+ README.md view
@@ -0,0 +1,33 @@+# atelier-core++Foundational effects and utilities for effect-based applications, built on [Effectful](https://github.com/haskell-effectful/effectful). Part of the **atelier** toolkit.++## Overview++`atelier-core` provides a set of composable Effectful effects and supporting types for building structured, observable applications.++| Module | Purpose |+|---|---|+| `Atelier.Component` | Structured component lifecycle (`setup → listeners → start`) |+| `Atelier.Config` | Configuration with environment variable overrides |+| `Atelier.Effects.Log` | Structured logging with hierarchical namespaces |+| `Atelier.Effects.Conc` | Thread management via [Ki](https://github.com/awkward-squad/ki) (structured concurrency) |+| `Atelier.Effects.Cache` | Caching with singleflight deduplication |+| `Atelier.Effects.Publishing` | Event publishing with context propagation |+| `Atelier.Effects.Monitoring.Tracing` | OpenTelemetry tracing |+| `Atelier.Effects.Monitoring.Metrics` | Prometheus metrics |+| `Atelier.Effects.FileWatcher` | Filesystem change notifications |+| `Atelier.Effects.Process` | External process management |++It also wraps a number of `IO`-based primitives (environment, clock, file system, console, POSIX) as effects so they can be interpreted and tested explicitly: `Atelier.Effects.Env`, `Atelier.Effects.Clock`, `Atelier.Effects.FileSystem`, `Atelier.Effects.Console`, `Atelier.Effects.Posix.*`, and more.++## Part of atelier++- [`atelier-prelude`](https://github.com/atelier-hub/tricorder/tree/main/atelier-prelude) — relude-based prelude with Effectful conventions+- [`atelier-core`](https://github.com/atelier-hub/tricorder/tree/main/atelier-core) — this package+- [`atelier-db`](https://github.com/atelier-hub/tricorder/tree/main/atelier-db) — relational database effect (Hasql/Rel8)+- [`atelier-testing`](https://github.com/atelier-hub/tricorder/tree/main/atelier-testing) — database-backed test utilities++## License++MIT — see [LICENSE](LICENSE).
+ atelier-core.cabal view
@@ -0,0 +1,215 @@+cabal-version: 2.0++-- This file has been generated from package.yaml by hpack version 0.38.2.+--+-- see: https://github.com/sol/hpack++name:           atelier-core+version:        0.1.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+homepage:       https://github.com/atelier-hub/tricorder#readme+bug-reports:    https://github.com/atelier-hub/tricorder/issues+author:         Christian Georgii+maintainer:     christian.georgii@tweag.io+license:        MIT+license-file:   LICENSE+build-type:     Simple+extra-doc-files:+    CHANGELOG.md+    README.md++source-repository head+  type: git+  location: https://github.com/atelier-hub/tricorder++library+  exposed-modules:+      Atelier.Component+      Atelier.Config+      Atelier.Effects.Arguments+      Atelier.Effects.Await+      Atelier.Effects.Cache+      Atelier.Effects.Cache.Config+      Atelier.Effects.Cache.Singleflight+      Atelier.Effects.Chan+      Atelier.Effects.Clock+      Atelier.Effects.Conc+      Atelier.Effects.Conc.Traced+      Atelier.Effects.Console+      Atelier.Effects.Debounce+      Atelier.Effects.Delay+      Atelier.Effects.Env+      Atelier.Effects.Exit+      Atelier.Effects.File+      Atelier.Effects.FileSystem+      Atelier.Effects.FileWatcher+      Atelier.Effects.Input+      Atelier.Effects.Internal.Coroutine+      Atelier.Effects.Iterator+      Atelier.Effects.Log+      Atelier.Effects.Monitoring.Metrics+      Atelier.Effects.Monitoring.Metrics.Registry+      Atelier.Effects.Monitoring.Metrics.Server+      Atelier.Effects.Monitoring.Tracing+      Atelier.Effects.Monitoring.Tracing.Provider+      Atelier.Effects.Posix.Daemons+      Atelier.Effects.Posix.IO+      Atelier.Effects.Process+      Atelier.Effects.Publishing+      Atelier.Effects.Tally+      Atelier.Effects.Timeout+      Atelier.Effects.UUID+      Atelier.Effects.Yield+      Atelier.Exception+      Atelier.Time+      Atelier.Types.Base64+      Atelier.Types.HttpApiDataReadShow+      Atelier.Types.JsonReadShow+      Atelier.Types.QuietSnake+      Atelier.Types.Semaphore+      Atelier.Types.Semaphore.STM+      Atelier.Types.WithDefaults+  other-modules:+      Paths_atelier_core+  autogen-modules:+      Paths_atelier_core+  hs-source-dirs:+      src+  default-extensions:+      BlockArguments+      DataKinds+      DeriveAnyClass+      DerivingStrategies+      DerivingVia+      DuplicateRecordFields+      FlexibleContexts+      GADTs+      LambdaCase+      MultiWayIf+      OverloadedLabels+      OverloadedRecordDot+      OverloadedStrings+      StrictData+      TemplateHaskell+      TypeFamilies+  ghc-options: -Weverything -Wno-unsafe -Wno-missing-safe-haskell-mode -Wno-monomorphism-restriction -Wno-missing-kind-signatures -Wno-missing-poly-kind-signatures -Wno-missing-role-annotations -Wno-missing-local-signatures -Wno-missing-import-lists -Wno-implicit-prelude -Wno-unticked-promoted-constructors -Wno-unused-packages -Wno-all-missed-specialisations -Wno-missed-specialisations -fplugin=Effectful.Plugin -threaded+  build-depends:+      aeson ==2.2.*+    , atelier-prelude ==0.1.*+    , base ==4.20.*+    , base64-bytestring ==1.2.*+    , bytestring ==0.12.*+    , casing ==0.1.*+    , containers ==0.7.*+    , contra-tracer ==0.2.*+    , daemons ==0.4.*+    , data-default ==0.8.*+    , directory ==1.3.*+    , effectful ==2.6.*+    , effectful-core ==2.6.*+    , effectful-plugin ==2.0.*+    , effectful-th ==1.0.*+    , filepath ==1.5.*+    , fsnotify ==0.4.*+    , hs-opentelemetry-api ==0.3.*+    , hs-opentelemetry-exporter-otlp ==0.1.*+    , hs-opentelemetry-sdk ==0.1.*+    , http-api-data ==0.7.*+    , http-types ==0.12.*+    , ki ==1.0.*+    , list-t ==1.0.*+    , optparse-applicative ==0.19.*+    , process ==1.6.*+    , prometheus-client ==1.1.*+    , prometheus-metrics-ghc ==1.0.*+    , stm ==2.5.*+    , stm-containers ==1.2.*+    , text ==2.1.*+    , time ==1.12.*+    , time-units ==1.0.*+    , typed-process ==0.2.*+    , unagi-chan ==0.4.*+    , unix ==2.8.*+    , unordered-containers ==0.2.*+    , uuid ==1.3.*+    , wai ==3.2.*+    , warp ==3.4.*+  mixins:+      base hiding (Prelude)+  default-language: GHC2021++test-suite atelier-test+  type: exitcode-stdio-1.0+  main-is: Driver.hs+  other-modules:+      Unit.Atelier.ConfigSpec+      Unit.Atelier.Effects.AwaitSpec+      Unit.Atelier.Effects.Cache.SingleflightSpec+      Unit.Atelier.Effects.CacheSpec+      Unit.Atelier.Effects.ChanSpec+      Unit.Atelier.Effects.Conc.TeardownStressSpec+      Unit.Atelier.Effects.Conc.TracedSpec+      Unit.Atelier.Effects.ConcSpec+      Unit.Atelier.Effects.ConsoleSpec+      Unit.Atelier.Effects.DebounceSpec+      Unit.Atelier.Effects.FileSystemSpec+      Unit.Atelier.Effects.FileWatcherSpec+      Unit.Atelier.Effects.IteratorSpec+      Unit.Atelier.Effects.LogSpec+      Unit.Atelier.Effects.PublishingSpec+      Unit.Atelier.Effects.TallySpec+      Unit.Atelier.Effects.YieldSpec+      Unit.Atelier.Types.Semaphore.STMSpec+      Unit.Atelier.Types.SemaphoreSpec+      Unit.Atelier.Types.WithDefaultsSpec+      Paths_atelier_core+  autogen-modules:+      Paths_atelier_core+  hs-source-dirs:+      test+  default-extensions:+      BlockArguments+      DataKinds+      DeriveAnyClass+      DerivingStrategies+      DerivingVia+      DuplicateRecordFields+      FlexibleContexts+      GADTs+      LambdaCase+      MultiWayIf+      OverloadedLabels+      OverloadedRecordDot+      OverloadedStrings+      StrictData+      TemplateHaskell+      TypeFamilies+  ghc-options: -Weverything -Wno-unsafe -Wno-missing-safe-haskell-mode -Wno-monomorphism-restriction -Wno-missing-kind-signatures -Wno-missing-poly-kind-signatures -Wno-missing-role-annotations -Wno-missing-local-signatures -Wno-missing-import-lists -Wno-implicit-prelude -Wno-unticked-promoted-constructors -Wno-unused-packages -Wno-all-missed-specialisations -Wno-missed-specialisations -fplugin=Effectful.Plugin -threaded -Wno-prepositive-qualified-module+  build-tool-depends:+      tasty-discover:tasty-discover+  build-depends:+      aeson ==2.2.*+    , async ==2.2.*+    , atelier-core ==0.1.*+    , atelier-prelude ==0.1.*+    , base ==4.20.*+    , bytestring ==0.12.*+    , containers ==0.7.*+    , data-default ==0.8.*+    , effectful ==2.6.*+    , effectful-core ==2.6.*+    , effectful-plugin ==2.0.*+    , hedgehog ==1.7.*+    , hs-opentelemetry-api ==0.3.*+    , hspec ==2.11.*+    , hspec-hedgehog ==0.3.*+    , stm ==2.5.*+    , stm-containers ==1.2.*+    , tasty ==1.5.*+    , tasty-hspec ==1.2.*+    , time ==1.12.*+  mixins:+      base hiding (Prelude)+  default-language: GHC2021
+ src/Atelier/Component.hs view
@@ -0,0 +1,132 @@+-- | A small component model for assembling long-running applications.+--+-- A 'Component' bundles a named unit of work with a lifecycle: one-off 'setup',+-- a set of 'listeners' and 'triggers' that run as forked threads, and a+-- post-'start' action. 'runSystem' drives a collection of components through+-- these phases in lockstep, so that (for example) every component has finished+-- 'setup' before any 'start' action runs and publishes events the others react+-- to.+module Atelier.Component+    ( -- * Components+      Component (..)+    , defaultComponent+    , Listener+    , Trigger++      -- * Running+    , runComponent+    , runSystem+    ) where++import Text.Casing (fromHumps, toQuietSnake)++import Atelier.Effects.Conc (Conc)+import Atelier.Effects.Log (Log)+import Atelier.Effects.Monitoring.Tracing (Tracing, withSpan)++import Atelier.Effects.Conc qualified as Conc+import Atelier.Effects.Log qualified as Log+++-- | A listener reacts to events and runs forever; it never returns normally,+-- hence the 'Void' result.+type Listener es = Eff es Void+++-- | A trigger initiates periodic or scheduled work and, like a 'Listener', runs+-- forever and never returns normally.+type Trigger es = Eff es Void+++-- | A named unit of application work together with its lifecycle hooks.+--+-- Build one by overriding the fields of 'defaultComponent' you care about.+data Component es = Component+    { name :: ~Text+    -- ^ Component name for tracing+    , setup :: Eff es ()+    -- ^ Setup component (runs before listeners/triggers start)+    , listeners :: Eff es [Listener es]+    -- ^ Event listeners (react to events)+    , triggers :: Eff es [Trigger es]+    -- ^ Triggers (initiate periodic/scheduled work)+    , start :: Eff es ()+    -- ^ Post-start actions (runs after all components have started)+    }+++-- | A 'Component' with no-op lifecycle hooks and no listeners or triggers.+--+-- Override the fields you need. 'name' is deliberately left as an 'error' so a+-- component created without a name fails fast rather than tracing anonymously.+defaultComponent :: (HasCallStack) => Component es+defaultComponent =+    Component+        { name = error "Missing component name"+        , setup = pure ()+        , listeners = pure []+        , triggers = pure []+        , start = pure ()+        }+++-- | Run a component by forking its listeners and triggers+runComponent :: (Conc :> es, Tracing :> es) => Component es -> Eff es ()+runComponent c = withSpan c.name $ do+    ls <- c.listeners+    ts <- c.triggers+    traverse_ Conc.fork_ ls+    traverse_ Conc.fork_ ts+++-- | Run multiple components with structured lifecycle coordination+--+-- Executes components in three sequential phases:+--   1. Run @setup for all components (initialization before activation)+--   2. Fork all listeners and triggers (components become active)+--   3. Fork @start for all components (background startup actions)+--+-- This separation allows components to prepare resources during setup, then perform+-- work during start that depends on listeners already running (e.g., publishing events).+-- The start phase is forked to allow parallel execution across components.+runSystem+    :: forall es+     . (Conc :> es, Log :> es, Tracing :> es)+    => [Component es]+    -> Eff es ()+runSystem components = Conc.scoped do+    -- Phase 1: Setup all components+    traverse_ setupComponent components++    -- Phase 2: Start all components (fork listeners/triggers)+    traverse_ startComponent components++    -- Phase 3: Fork post-start actions+    traverse_ postStartComponent components++    Conc.awaitAll+  where+    setupComponent :: Component es -> Eff es ()+    setupComponent c = do+        let name = formatName c.name+        Log.debug $ "Setting up component: " <> name+        withSpan (name <> ":setup")+            $ c.setup++    startComponent :: Component es -> Eff es ()+    startComponent c = do+        let name = formatName c.name+        Log.debug $ "Starting listeners/triggers for component: " <> name+        runComponent c++    postStartComponent :: Component es -> Eff es ()+    postStartComponent c = do+        let name = formatName c.name+        Log.debug $ "Forking start phase for component: " <> name+        void . Conc.fork+            $ withSpan (name <> ":start")+            $ c.start+++formatName :: Text -> Text+formatName = toText . toQuietSnake . fromHumps . toString
+ src/Atelier/Config.hs view
@@ -0,0 +1,182 @@+{-# LANGUAGE AllowAmbiguousTypes #-}++-- | Layered application configuration.+--+-- A configuration is assembled from a base JSON\/YAML document plus environment+-- variable overrides, then decoded on demand by type-level key:+--+-- * 'envOverrides' turns @PREFIX__A__B=value@ variables into a nested JSON+--   'Value';+-- * 'deepMerge' overlays that onto the base document, producing a+--   'LoadedConfig';+-- * 'extractConfig' and 'extractNestedConfig' decode a section by 'Symbol' key,+--   falling back to the target type's 'Default' instance when the key is+--   missing or fails to decode;+-- * 'runConfig' hands a decoded section to a computation as a 'Reader'.+--+-- == Worked example+--+-- Given a base document (say, decoded from a @base.yaml@ holding+-- @server: { port: 8080, host: localhost }@) and a @MYAPP@ environment prefix:+--+-- @+-- data Server = Server { port :: Int, host :: Text }+--     deriving stock (Generic)+--     deriving (FromJSON) via (QuietSnake Server)+--+-- instance Default Server where+--     def = Server { port = 80, host = \"0.0.0.0\" }+--+-- loadServer :: (Env :> es) => Value -> Eff es Server+-- loadServer base = do+--     overrides <- envOverrides \"MYAPP\"            -- e.g. MYAPP__SERVER__PORT=9090+--     let loaded = LoadedConfig (deepMerge base overrides)+--     pure (extractNestedConfig \@\"server\" loaded)+-- @+--+-- With @MYAPP__SERVER__PORT=9090@ set in the environment, @loadServer@ yields+-- @Server { port = 9090, host = \"localhost\" }@: the env override wins on+-- @port@, the base document supplies @host@, and the 'Default' instance would+-- cover any field absent from both.+module Atelier.Config+    ( envOverrides+    , deepMerge+    , extractConfig+    , extractNestedConfig+    , LoadedConfig (..)+    , runConfig+    ) where++import Data.Aeson (FromJSON (..), Value (..))+import Data.Default (Default (..))+import Effectful.Exception (evaluate)+import Effectful.Reader.Static (Reader, ask, runReader)+import GHC.TypeLits (KnownSymbol, Symbol, symbolVal)++import Data.Aeson qualified as Aeson+import Data.Aeson.KeyMap qualified as KM+import Data.Text qualified as T+import Data.Text.Encoding qualified as TE++import Atelier.Effects.Env (Env, getEnvironment)+++-- | Build a nested JSON Object from environment variables with the given prefix.+-- Variables are expected in the form PREFIX__SEG1__SEG2=value.+-- Double underscore is the path separator; single underscore is preserved within segments.+envOverrides :: (Env :> es) => Text -> Eff es Value+envOverrides prefix = do+    allEnv <- getEnvironment+    let prefixStr = toString prefix <> "__"+        matching = [(k, v) | (k, v) <- allEnv, prefixStr `isPrefixOf` k]+        pairs = [(splitPath (drop (length prefixStr) k), parseScalar (toText v)) | (k, v) <- matching]+    pure $ foldl' insertNested (Object KM.empty) pairs+  where+    splitPath :: String -> [Text]+    splitPath = map T.toLower . T.splitOn "__" . toText++    insertNested :: Value -> ([Text], Value) -> Value+    insertNested base ([], _) = base+    insertNested base ([k], v) =+        let key = fromString (toString k)+        in  Object $ case base of+                Object m -> KM.insert key v m+                _ -> KM.singleton key v+    insertNested base (k : ks, v) =+        let key = fromString (toString k)+            child = case base of+                Object m -> fromMaybe (Object KM.empty) (KM.lookup key m)+                _ -> Object KM.empty+            merged = insertNested child (ks, v)+        in  Object $ case base of+                Object m -> KM.insert key merged m+                _ -> KM.singleton key merged+++-- | Parse a scalar text value as its natural JSON type when possible,+-- falling back to a JSON String.+parseScalar :: Text -> Value+parseScalar t =+    fromMaybe (String t)+        $ Aeson.decodeStrict+        $ TE.encodeUtf8 t+++-- | Deep merge two JSON values. Right wins on conflict for non-Object values;+-- Objects are merged recursively.+deepMerge :: Value -> Value -> Value+deepMerge (Object l) (Object r) = Object $ KM.unionWith deepMerge l r+deepMerge _ r = r+++-- | A fully merged configuration document (base overlaid with overrides), ready+-- to have sections extracted from it by key.+newtype LoadedConfig = LoadedConfig Value+++-- | Pure variant of 'runConfig': extract and decode a config section from a 'LoadedConfig'+-- without entering the effect stack. Falls back to the type's 'Default' instance on+-- missing key or decode failure.+extractConfig+    :: forall (key :: Symbol) r+     . (Default r, FromJSON r, KnownSymbol key)+    => LoadedConfig+    -> r+extractConfig (LoadedConfig root) =+    case root of+        Aeson.Object m ->+            case KM.lookup (fromString (symbolVal (Proxy @key))) m of+                Nothing -> def+                Just v -> case Aeson.fromJSON v of+                    Aeson.Success a -> a+                    Aeson.Error _ -> def+        _ -> def+++-- | Variant of 'extractConfig' that extracts nested configuration values.+-- Nested properties are delimited by @"."@, so @foo.bar@ would attempt to+-- extract the nested property @bar@ contained in the top-level property @foo@.+--+-- Example:+--+-- Assuming @cfg@ is a 'LoadedConfig' representing the following JSON/YAML+-- structure:+--+-- @+-- {+--   "foo": {+--     "bar": "test"+--   }+-- }+-- @+--+-- The following will be @True@:+--+-- @+-- extractNestedConfig \@"foo.bar" \@Text cfg == "test"+-- @+extractNestedConfig :: forall (key :: Symbol) r. (Default r, FromJSON r, KnownSymbol key) => LoadedConfig -> r+extractNestedConfig (LoadedConfig root) = go props root+  where+    props = T.splitOn "." $ toText $ symbolVal $ Proxy @key++    go (p : ps) (Aeson.Object m) = maybe def (go ps) $ KM.lookup (fromString $ toString p) m+    go (_ : _) _ = def+    go [] x = fromJSON x++    fromJSON x = case Aeson.fromJSON x of+        Aeson.Success a -> a+        Aeson.Error _ -> def+++-- | Extract and decode a (potentially nested) config section by type-level key+-- from the root config Value.+-- Falls back to the type's 'Default' instance if the (nested) key is absent.+runConfig+    :: forall (key :: Symbol) r es a+     . (Default r, FromJSON r, KnownSymbol key, Reader LoadedConfig :> es)+    => Eff (Reader r : es) a -> Eff es a+runConfig act = do+    loadedCfg <- ask+    cfg <- evaluate $ extractNestedConfig @key loadedCfg+    runReader (cfg) act
+ src/Atelier/Effects/Arguments.hs view
@@ -0,0 +1,39 @@+-- | Effect for parsing command-line arguments.+--+-- A thin wrapper over @optparse-applicative@'s 'Opt.execParser', so callers+-- read and parse @argv@ through the effect system rather than raw 'IO'.+module Atelier.Effects.Arguments+    ( -- * Effect+      Arguments++      -- * Re-exported from @optparse-applicative@+    , ParserInfo++      -- * Operations+    , execParser++      -- * Interpreters+    , runArgumentsIO+    ) where++import Effectful (Effect, IOE)+import Effectful.Dispatch.Dynamic (interpret_)+import Effectful.TH (makeEffect)+import Options.Applicative (ParserInfo)++import Options.Applicative qualified as Opt+++-- | Reading and parsing command-line arguments.+data Arguments :: Effect where+    -- | Read @argv@ and parse it with the given parser, printing usage and+    -- exiting on failure (see @optparse-applicative@'s 'Opt.execParser').+    ExecParser :: ParserInfo a -> Arguments m a+++makeEffect ''Arguments+++runArgumentsIO :: (IOE :> es) => Eff (Arguments : es) a -> Eff es a+runArgumentsIO = interpret_ \case+    ExecParser pinfo -> liftIO $ Opt.execParser pinfo
+ src/Atelier/Effects/Await.hs view
@@ -0,0 +1,28 @@+-- | The consuming half of a 'Yield'\/'Await' coroutine pair.+--+-- An 'Await' computation requests values one at a time, analogous to the+-- @Reader@\/@Input@ effects. Pair it with a 'Yield' producer — for example via+-- 'awaitYield' — to stream values from one computation into another. The effect+-- and its operations live in "Atelier.Effects.Internal.Coroutine" and are+-- re-exported here.+module Atelier.Effects.Await+    ( -- * Effect+      Await++      -- * Operations+    , await+    , takeAwait++      -- * Interpreters+    , eachAwait+    , awaitYield+    ) where++import Atelier.Effects.Internal.Coroutine+    ( Await+    , await+    , awaitYield+    , eachAwait+    , takeAwait+    )+
+ src/Atelier/Effects/Cache.hs view
@@ -0,0 +1,184 @@+-- | Generic key-value cache effect with pluggable eviction strategies+module Atelier.Effects.Cache+    ( -- * Effect+      Cache+    , cacheLookup+    , cacheInsert+    , cacheDelete+    , cacheModify++      -- * Re-exports+    , module Atelier.Effects.Cache.Config++      -- * Interpreters+    , runCacheTtl+    , runCacheTtlWithWait+    , runCacheForever+    ) where++import Data.Time (NominalDiffTime, UTCTime, addUTCTime)+import Effectful (Effect)+import Effectful.Concurrent (Concurrent)+import Effectful.Concurrent.STM (STM)+import Effectful.Dispatch.Dynamic (interpretWith)+import Effectful.Reader.Static (Reader, ask)+import Effectful.TH (makeEffect)+import StmContainers.Map (Map)+import Prelude hiding (Map)++import Effectful.Concurrent.STM qualified as STM+import ListT qualified+import StmContainers.Map qualified as Map++import Atelier.Effects.Cache.Config+import Atelier.Effects.Clock (Clock, currentTime)+import Atelier.Effects.Conc (Conc)+import Atelier.Effects.Delay (Delay)+import Atelier.Effects.Log (Log)+import Atelier.Time (Microsecond, nominalDiffTime)++import Atelier.Effects.Conc qualified as Conc+import Atelier.Effects.Delay qualified as Delay+import Atelier.Effects.Log qualified as Log+++-- | Effect for a generic key-value cache.+data Cache key value :: Effect where+    -- | Look up a key, returning 'Nothing' if it is absent.+    CacheLookup :: key -> Cache key value m (Maybe value)+    -- | Insert or overwrite the value at a key.+    CacheInsert :: key -> value -> Cache key value m ()+    -- | Remove a key from the cache.+    CacheDelete :: key -> Cache key value m ()+    -- | Apply a function to a key's current value (or its absence), store the+    -- result, and return it.+    CacheModify :: key -> (Maybe value -> value) -> Cache key value m value+++makeEffect ''Cache+++-- | Internal entry wrapping a value with its insertion timestamp+data CacheEntry value = CacheEntry+    { value :: !value+    , createdAt :: !UTCTime+    }+++-- | Run the Cache effect with TTL-based eviction+--+-- Entries are evicted after @entryTtl@ from their first insertion.+-- Subsequent updates to the same key preserve the original timestamp.+-- A background thread runs every @cleanupInterval@ to remove expired entries.+runCacheTtl+    :: forall key value es a+     . ( Clock :> es+       , Conc :> es+       , Concurrent :> es+       , Delay :> es+       , Hashable key+       , Log :> es+       , Reader Config :> es+       )+    => Eff (Cache key value : es) a -> Eff es a+runCacheTtl act = do+    cfg <- ask+    runCacheTtlWithWait (Delay.wait $ nominalDiffTime @Microsecond cfg.cleanupInterval) act+++-- | Like 'runCacheTtl', but with the cleanup cadence supplied explicitly as a+-- waiting action rather than read from 'Config'. Each time the action+-- completes, expired entries are swept. Useful for tests that drive cleanup+-- deterministically.+runCacheTtlWithWait+    :: forall key value es a+     . ( Clock :> es+       , Conc :> es+       , Concurrent :> es+       , Hashable key+       , Log :> es+       , Reader Config :> es+       )+    => Eff es ()+    -- ^ Action that completes when it is time to perform cleanup.+    -> Eff (Cache key value : es) a+    -> Eff es a+runCacheTtlWithWait waitForNextCleanup action = do+    cfg <- ask @Config+    store <- STM.atomically (Map.new :: STM (Map key (CacheEntry value)))++    Conc.fork_ $ forever $ Log.withNamespace "Cache" do+        waitForNextCleanup+        now <- currentTime+        evicted <- STM.atomically $ evictExpiredEntries store cfg.entryTtl now++        when (evicted > 0)+            $ Log.debug+            $ "Evicted " <> show evicted <> " entries"++    interpretWith action $ \_ -> \case+        CacheLookup key ->+            fmap (.value) <$> STM.atomically (Map.lookup key store)+        CacheInsert key val -> do+            now <- currentTime+            STM.atomically $ do+                existing <- Map.lookup key store+                let entry = case existing of+                        Nothing -> CacheEntry {value = val, createdAt = now}+                        Just e -> e {value = val} -- preserve original timestamp+                Map.insert entry key store+        CacheDelete key ->+            STM.atomically $ Map.delete key store+        CacheModify key f -> do+            now <- currentTime+            STM.atomically $ do+                existing <- Map.lookup key store+                let newEntry = case existing of+                        Nothing -> CacheEntry {value = f Nothing, createdAt = now}+                        Just e -> e {value = f (Just e.value)}+                Map.insert newEntry key store+                pure newEntry.value+++evictExpiredEntries+    :: (Hashable key)+    => Map key (CacheEntry value)+    -> NominalDiffTime+    -> UTCTime+    -> STM Int+evictExpiredEntries store ttl now =+    ListT.fold+        ( \count (k, v) ->+            if now >= addUTCTime ttl v.createdAt then+                Map.delete k store $> count + 1+            else+                pure count+        )+        0+        $ Map.listT store+++-- | Run the Cache effect with no TTL (entries live forever).+--+-- Uses a plain STM 'Map' with no eviction. Useful for tests and+-- session-scoped caches where eviction is never needed.+runCacheForever+    :: forall key value es a+     . (Concurrent :> es, Hashable key)+    => Eff (Cache key value : es) a+    -> Eff es a+runCacheForever action = do+    store <- STM.atomically (Map.new :: STM (Map key value))+    interpretWith action $ \_ -> \case+        CacheLookup key ->+            STM.atomically $ Map.lookup key store+        CacheInsert key val ->+            STM.atomically $ Map.insert val key store+        CacheDelete key ->+            STM.atomically $ Map.delete key store+        CacheModify key f ->+            STM.atomically $ do+                existing <- Map.lookup key store+                let newVal = f existing+                Map.insert newVal key store+                pure newVal
+ src/Atelier/Effects/Cache/Config.hs view
@@ -0,0 +1,33 @@+-- | Configuration shared by the TTL cache interpreters.+--+-- 'Config' controls how long entries live and how often the background eviction+-- sweep runs. It is re-exported by "Atelier.Effects.Cache" and+-- "Atelier.Effects.Tally".+module Atelier.Effects.Cache.Config+    ( Config (..)+    ) where++import Data.Aeson (FromJSON)+import Data.Default (Default (..))+import Data.Time (NominalDiffTime)++import Atelier.Types.QuietSnake (QuietSnake (..))+++-- | Configuration for a TTL-evicting cache+data Config = Config+    { entryTtl :: !NominalDiffTime+    -- ^ Time-to-live for cache entries. After this duration from first insertion, entries are evicted.+    , cleanupInterval :: !NominalDiffTime+    -- ^ How often the background cleanup thread runs to evict expired entries.+    }+    deriving stock (Eq, Generic, Show)+    deriving (FromJSON) via QuietSnake Config+++instance Default Config where+    def =+        Config+            { entryTtl = 12 * 3600 -- 12 hours in seconds+            , cleanupInterval = 3600 -- 1 hour in seconds+            }
+ src/Atelier/Effects/Cache/Singleflight.hs view
@@ -0,0 +1,140 @@+-- | A singleflight cache effect: deduplicate concurrent computations of the+-- same key.+--+-- When several threads request the same key at once, the first runs the+-- computation while the rest wait and share its result — so an expensive lookup+-- happens once per key per in-flight window. Results (and exceptions) can also+-- be seeded with 'updateCache' or invalidated with 'removeFromCache'. Each+-- operation is traced (see "Atelier.Effects.Monitoring.Tracing").+module Atelier.Effects.Cache.Singleflight+    ( Singleflight+    , withCache+    , updateCache+    , removeFromCache+    , runSingleflight+    ) where++import Effectful (Effect)+import Effectful.Concurrent (Concurrent)+import Effectful.Concurrent.STM (TMVar)+import Effectful.Dispatch.Dynamic (interpretWith, localSeqUnlift)+import Effectful.Exception (throwIO, trySync)+import Effectful.TH (makeEffect)+import StmContainers.Map (Map)+import Prelude hiding (Map)++import Effectful.Concurrent.STM qualified as STM+import StmContainers.Map qualified as Map++import Atelier.Effects.Monitoring.Tracing (Tracing, addAttribute, withSpan)+++-- | Singleflight cache effect for deduplicating concurrent computations+--+-- When multiple concurrent operations request the same key:+-- - The first request executes the computation+-- - Subsequent requests wait for and share the result+-- - After completion, all requests receive the same result+data Singleflight key value :: Effect where+    -- | Execute a computation with singleflight semantics+    -- If another computation for the same key is in-flight, wait for its result+    WithCache :: (Hashable key) => key -> m value -> Singleflight key value m value+    -- | Pre-populate the cache with known values+    -- Useful when values are already available to avoid redundant computation+    UpdateCache :: [(key, value)] -> Singleflight key value m ()+    -- | Remove keys from the cache so future requests recompute from source+    RemoveFromCache :: [key] -> Singleflight key value m ()+++makeEffect ''Singleflight+++type InFlightMap key value = Map key (TMVar (Either SomeException value))+++-- | Run the Singleflight effect with an in-memory cache+runSingleflight+    :: forall key value es a+     . (Concurrent :> es, Hashable key, Tracing :> es)+    => Eff (Singleflight key value : es) a+    -> Eff es a+runSingleflight action = do+    -- Initialize the cache+    cache :: InFlightMap key value <- STM.atomically Map.new++    -- Run with the cache in Reader context, interpreting Singleflight operations+    interpretWith action $ \env -> \case+        WithCache key computation -> localSeqUnlift env $ \unlift -> withSpan "singleflight.with_cache" do+            -- Singleflight pattern: check if computation is already in-flight.+            -- Also attempt a non-blocking read of any existing result in the same transaction.+            (mvar, isFirst, mResult) <- STM.atomically $ do+                existing <- Map.lookup key cache+                case existing of+                    Just tmvar -> do+                        mResult <- STM.tryReadTMVar tmvar+                        pure (tmvar, False, mResult)+                    Nothing -> do+                        -- Create new empty TMVar and insert into cache+                        tmvar <- STM.newEmptyTMVar+                        Map.insert tmvar key cache+                        pure (tmvar, True, Nothing)++            case (isFirst, mResult) of+                (_, Just (Right value)) -> do+                    addAttribute @Text "singleflight.outcome" "hit"+                    pure value+                (_, Just (Left exception)) -> do+                    addAttribute @Text "singleflight.outcome" "hit"+                    throwIO exception+                (True, Nothing) -> do+                    addAttribute @Text "singleflight.outcome" "compute"+                    result <- unlift $ trySync computation++                    -- Try to fill the TMVar with result (success or failure) for waiters+                    -- Use tryPutTMVar in case updateCache already filled it+                    filled <- STM.atomically $ STM.tryPutTMVar mvar result++                    if filled then do+                        -- We successfully filled the TMVar with our result+                        -- If it was an exception, remove from cache so future requests can retry+                        case result of+                            Left _exception -> do+                                STM.atomically $ Map.delete key cache+                            Right _ -> pure ()++                        -- Return the result or re-throw the exception+                        case result of+                            Left exception -> throwIO exception+                            Right value -> pure value+                    else do+                        -- updateCache filled it before us - read and use that value+                        finalResult <- STM.atomically $ STM.readTMVar mvar+                        case finalResult of+                            Left exception -> throwIO exception+                            Right value -> pure value+                (False, Nothing) -> do+                    addAttribute @Text "singleflight.outcome" "wait"+                    result <-+                        withSpan "singleflight.wait"+                            $ STM.atomically+                            $ STM.readTMVar mvar+                    case result of+                        Left exception -> throwIO exception+                        Right value -> pure value+        UpdateCache entries -> withSpan "singleflight.update_cache" do+            STM.atomically $ do+                forM_ entries $ \(key, value) -> do+                    existing <- Map.lookup key cache+                    case existing of+                        Just existingTMVar -> do+                            -- In-flight computation exists: update its result+                            -- Try to take whatever value is there (or Nothing if empty)+                            _ <- STM.tryTakeTMVar existingTMVar+                            -- Put the correct value (wrapped in Right for success)+                            STM.putTMVar existingTMVar (Right value)+                        Nothing -> do+                            -- No in-flight computation: create fresh TMVar with value+                            tmvar <- STM.newTMVar (Right value)+                            Map.insert tmvar key cache+        RemoveFromCache keys -> withSpan "singleflight.remove_from_cache" do+            STM.atomically $ forM_ keys $ \key -> Map.delete key cache
+ src/Atelier/Effects/Chan.hs view
@@ -0,0 +1,122 @@+{-# OPTIONS_GHC -Wno-redundant-constraints #-}++-- | A typed, unbounded channel effect backed by @unagi-chan@.+--+-- Exposes the split in\/out ends of a fast concurrent queue as an effect, plus a+-- batched read ('readChanBatched') for draining several items at once. The+-- 'InChan' and 'OutChan' types are re-exported so callers need not depend on+-- @unagi-chan@ directly.+--+-- @+-- -- write a few items (writeChan never blocks), then drain them in one batch:+-- pipeline :: (Chan :> es, Timeout :> es) => Eff es (NonEmpty Int)+-- pipeline = do+--     (inn, out) <- newChan+--     traverse_ (writeChan inn) [1 .. 10]+--     readChanBatched (50 :: Millisecond) 100 out   -- one blocking read, up to 100 items+--+-- -- dupChan gives a second, independent read end that sees later writes:+-- broadcast :: (Chan :> es) => Eff es (Int, Int)+-- broadcast = do+--     (inn, out1) <- newChan+--     out2 <- dupChan inn+--     writeChan inn 7+--     (,) <$> readChan out1 <*> readChan out2       -- (7, 7)+-- @+module Atelier.Effects.Chan+    ( -- * Effect+      Chan+    , newChan+    , readChan+    , writeChan+    , dupChan+    , runChan++      -- * Channel Types++      -- | Re-exported from the underlying channel implementation.+      -- Import these from this module rather than directly from Unagi+      -- to maintain abstraction boundaries.+    , InChan+    , OutChan+    , readChanBatched+    ) where++import Control.Concurrent.Chan.Unagi (InChan, OutChan)+import Data.Time.Units (TimeUnit, toMicroseconds)+import Effectful (Dispatch (..), DispatchOf, Effect, IOE)+import Effectful.Dispatch.Static (SideEffects (..), StaticRep, evalStaticRep, unsafeEff_)+import Effectful.State.Static.Shared (evalState, get, modify)+import Effectful.Timeout (Timeout, timeout)++import Control.Concurrent.Chan.Unagi qualified as Unagi+++-- | Effect for creating and operating on bidirectional channels.+data Chan :: Effect+++type instance DispatchOf Chan = Static WithSideEffects+data instance StaticRep Chan = Chan+++-- | Run the 'Chan' effect, allowing channel operations to perform their IO.+runChan :: forall a es. (IOE :> es) => Eff (Chan : es) a -> Eff es a+runChan = evalStaticRep Chan+++-- | Create a new channel, returning its write ('InChan') and read ('OutChan')+-- ends.+newChan :: forall a es. (Chan :> es) => Eff es (InChan a, OutChan a)+newChan =+    unsafeEff_ Unagi.newChan+++-- | Read the next item from a channel, blocking until one is available.+readChan :: forall a es. (Chan :> es) => OutChan a -> Eff es a+readChan outChan =+    unsafeEff_ $ Unagi.readChan outChan+++-- | Write an item to a channel. Never blocks (the channel is unbounded).+writeChan :: forall a es. (Chan :> es) => InChan a -> a -> Eff es ()+writeChan inChan val =+    unsafeEff_ $ Unagi.writeChan inChan val+++-- | Duplicate a channel, producing a new read end that observes every item+-- written after the duplication.+dupChan :: forall a es. (Chan :> es) => InChan a -> Eff es (OutChan a)+dupChan inChan =+    unsafeEff_ $ Unagi.dupChan inChan+++-- | Read a batch of items from a channel.+--+-- Blocks until at least one item is available, then attempts to read+-- up to @batchSize@ items total within the given timeout. Always returns+-- at least one item.+readChanBatched+    :: forall t a es+     . ( Chan :> es+       , TimeUnit t+       , Timeout :> es+       )+    => t+    -- ^ Timeout for reading additional items after the first+    -> Int+    -- ^ Maximum number of items to read (batch size)+    -> OutChan a+    -- ^ Channel to read from+    -> Eff es (NonEmpty a)+    -- ^ Non-empty batch of items (at least one, up to batch size)+readChanBatched timeoutDuration batchSize outChan = do+    evalState @[a] [] $ do+        h <- readChan outChan -- blocking, get first item+        _ <- timeout (fromIntegral (toMicroseconds timeoutDuration))+            $ replicateM_ (batchSize - 1)+            $ do+                x <- readChan outChan+                modify (x :)+        rest <- get+        pure $ h :| reverse rest
+ src/Atelier/Effects/Clock.hs view
@@ -0,0 +1,69 @@+-- | A clock effect for reading the current time and time zone.+--+-- Putting wall-clock reads behind an effect keeps time-dependent code testable:+-- 'runClock' uses the system clock, while 'runClockConst', 'runClockState' and+-- 'runClockList' supply deterministic times for tests.+module Atelier.Effects.Clock+    ( Clock+    , UTCTime+    , TimeZone+    , currentTime+    , currentTimeZone+    , runClock+    , runClockConst+    , runClockState+    , runClockList+    ) where++import Data.Time (UTCTime, getCurrentTime)+import Data.Time.LocalTime (TimeZone, getCurrentTimeZone, utc)+import Effectful (Effect, IOE)+import Effectful.Dispatch.Dynamic (interpret_, reinterpret)+import Effectful.State.Static.Shared (State, evalState, get, put)+import Effectful.TH (makeEffect)+++-- | Effect for reading the current time and time zone.+data Clock :: Effect where+    -- | The current wall-clock time, in UTC.+    CurrentTime :: Clock m UTCTime+    -- | The system's current time zone.+    CurrentTimeZone :: Clock m TimeZone+++makeEffect ''Clock+++-- | Interpret 'Clock' against the real system clock.+runClock :: (IOE :> es) => Eff (Clock : es) a -> Eff es a+runClock = interpret_ $ \case+    CurrentTime -> liftIO getCurrentTime+    CurrentTimeZone -> liftIO getCurrentTimeZone+++-- | Interpret 'Clock' so 'currentTime' always returns a fixed time. The time+-- zone is reported as 'utc'.+runClockConst :: UTCTime -> Eff (Clock : es) a -> Eff es a+runClockConst time = interpret_ $ \case+    CurrentTime -> pure time+    CurrentTimeZone -> pure utc+++-- | Interpret 'Clock' so 'currentTime' reads from a mutable 'State' cell,+-- letting a test advance \"now\" explicitly. The time zone is reported as 'utc'.+runClockState :: (State UTCTime :> es) => Eff (Clock : es) a -> Eff es a+runClockState = interpret_ $ \case+    CurrentTime -> get+    CurrentTimeZone -> pure utc+++-- | Scripted interpreter for testing: returns times from a pre-loaded list in+-- order. Each 'currentTime' call pops the next item. Crashes if the list is+-- exhausted.+runClockList :: [UTCTime] -> Eff (Clock : es) a -> Eff es a+runClockList times = reinterpret (evalState times) $ \_ -> \case+    CurrentTime ->+        get >>= \case+            [] -> error "runClockList: no more times in queue"+            t : ts -> put ts >> pure t+    CurrentTimeZone -> pure utc
+ src/Atelier/Effects/Conc.hs view
@@ -0,0 +1,175 @@+-- | Structured concurrency built on @ki@.+--+-- 'Conc' exposes forking, awaiting, racing and nurseries ('scoped') as an+-- effect, so concurrent code stays in 'Eff' and inherits structured-concurrency+-- guarantees: every child thread is bound to a scope and is cancelled when that+-- scope closes. The base interpreter ('runConc') ignores tracing; use+-- "Atelier.Effects.Conc.Traced" to propagate OpenTelemetry context across forks.+module Atelier.Effects.Conc+    ( -- * Effect+      Conc (..)+    , Thread+    , fork+    , fork_+    , await+    , awaitAll+    , forkTry+    , race++      -- * Scope+    , Scope (..)+    , scoped+    , restartableForkWith+    , restartableForkLoop++      -- * Interpreters+    , runConcBase+    , runConc++      -- * Unlift Strategy+    , concStrat+    )+where++import Effectful+    ( Effect+    , IOE+    , Limit (..)+    , Persistence (..)+    , UnliftStrategy (..)+    , inject+    , withEffToIO+    )+import Effectful.Concurrent.MVar (Concurrent, newEmptyMVar, putMVar, takeMVar)+import Effectful.Concurrent.STM (atomically, runConcurrent)+import Effectful.Dispatch.Dynamic+    ( EffectHandler+    , interpose+    , interpret+    , localLend+    , localUnlift+    , localUnliftIO+    )+import Effectful.TH (makeEffect)++import Ki qualified+++data Conc :: Effect where+    -- | Fork a thread that terminates. Use @void . fork@ to discard the handle.+    Fork :: m a -> Conc m (Thread a)+    -- | Fork a thread that never terminates (e.g. a server loop).+    -- The @Void@ return type enforces this — use 'fork' for threads that exit.+    Fork_ :: m Void -> Conc m ()+    -- | Block until a forked 'Thread' finishes and return its result.+    Await :: Thread a -> Conc m a+    -- | Block until every thread in the current scope has finished.+    AwaitAll :: Conc m ()+    -- | Like 'Fork', but the thread captures a synchronous exception of type @e@+    -- as a 'Left' instead of propagating it to the enclosing scope.+    ForkTry :: (Exception e) => m a -> Conc m (Thread (Either e a))+    -- | Races two computations concurrently and returns the result of the+    -- operation that finished first.+    Race :: m a -> m b -> Conc m (Either a b)+    -- | Open a nursery scope. Threads forked inside it are awaited or cancelled+    -- when the action returns.+    Scoped :: m a -> Conc m a+++-- | A concurrency scope (nursery) that forked threads are bound to.+newtype Scope = Scope Ki.Scope+++-- | A handle to a forked thread, awaited with 'await'.+newtype Thread a = Thread (Ki.Thread a)+++makeEffect ''Conc+++-- | Forks an action in a loop, with a setup step that runs in the scope before+-- each fork. Each time @signal@ returns, the current fork is cancelled, and+-- setup and fork are run again. The setup result is passed to the forked+-- action, structurally guaranteeing it completes before the fork starts.+restartableForkWith :: (Conc :> es) => Eff es () -> Eff es r -> (r -> Eff es a) -> Eff es Void+restartableForkWith signal setup action = forever $ scoped do+    r <- setup+    _ <- fork (action r)+    signal+++-- | Like 'restartableForkWith', but threads a value across iterations: the+-- signal returns the next @r@, which is passed to the next fork. The initial+-- @r@ seeds the first fork.+restartableForkLoop :: (Conc :> es) => r -> Eff es r -> (r -> Eff es a) -> Eff es Void+restartableForkLoop initial signal action = go initial+  where+    go r = scoped do+        _ <- fork (action r)+        r' <- signal+        go r'+++-- | Base interpreter: resolves 'Conc' operations using Ki.+--+-- Does not handle trace context propagation. Use 'Atelier.Effects.Conc.Traced.runConc'+-- for automatic span link propagation across forks.+runConcBase :: forall es a. (Concurrent :> es, IOE :> es) => Scope -> Eff (Conc : es) a -> Eff es a+runConcBase (Scope scope0) = interpret $ handler @es scope0+  where+    handler :: forall es'. (Concurrent :> es', IOE :> es') => Ki.Scope -> EffectHandler Conc es'+    handler scope env = \case+        Fork action ->+            localUnliftIO env concStrat \unlift ->+                fmap Thread . liftIO . Ki.fork scope $ unlift action+        Fork_ action ->+            localUnliftIO env concStrat \unlift ->+                Ki.fork_ scope $ unlift action+        ForkTry action ->+            localUnliftIO env concStrat \unlift ->+                fmap Thread . liftIO . Ki.forkTry scope $ unlift action+        Await (Thread thread) ->+            runConcurrent . atomically $ Ki.await thread+        AwaitAll ->+            runConcurrent . atomically $ Ki.awaitAll scope+        Race ma mb ->+            localLend @'[Concurrent] env concStrat \lend ->+                localUnliftIO env concStrat \unlift ->+                    Ki.scoped \raceScope -> do+                        ref <- unlift $ inject $ lend newEmptyMVar+                        void+                            $ Ki.fork raceScope+                            $ unlift+                            $ lend . putMVar ref . Left =<< ma+                        void+                            $ Ki.fork raceScope+                            $ unlift+                            $ lend . putMVar ref . Right =<< mb+                        unlift $ lend $ takeMVar ref+        Scoped m ->+            localUnlift env concStrat \unliftEff ->+                localLend @'[IOE, Concurrent] env concStrat \lend ->+                    withEffToIO concStrat \unliftIO ->+                        Ki.scoped \subScope ->+                            unliftIO+                                . unliftEff+                                . lend+                                . interpose (handler subScope)+                                . inject+                                $ m+++-- | Run 'Conc' in a new Ki scope without trace context propagation.+--+-- Suitable for tests and contexts where tracing is not needed.+runConc :: (Concurrent :> es, IOE :> es) => Eff (Conc : es) a -> Eff es a+runConc eff = withEffToIO concStrat $ \unlift ->+    Ki.scoped $ \scope ->+        unlift $ runConcBase (Scope scope) eff+++-- | The unlift strategy used when running forked actions: a persistent,+-- unlimited concurrent unlift, so forked threads may themselves use the effects+-- of the enclosing computation. Shared with "Atelier.Effects.Conc.Traced".+concStrat :: UnliftStrategy+concStrat = ConcUnlift Persistent Unlimited
+ src/Atelier/Effects/Conc/Traced.hs view
@@ -0,0 +1,86 @@+-- | Tracing integration for the 'Conc' effect.+--+-- Provides interpreters and interposers that automatically propagate+-- OpenTelemetry trace context across thread boundaries using span links.+module Atelier.Effects.Conc.Traced+    ( -- * Interpreters+      runConc+    , runConcByConfig+    , runConcTraced++      -- * Interposers+    , withConcTracingLinks+    )+where++import Effectful (IOE, raise, withEffToIO)+import Effectful.Concurrent (Concurrent)+import Effectful.Dispatch.Dynamic (interpose, localLend, localUnlift, passthrough)+import Effectful.Reader.Static (Reader, asks)++import Ki qualified++import Atelier.Effects.Conc (Conc (..), Scope (..), concStrat, fork, forkTry, fork_, runConcBase)+import Atelier.Effects.Monitoring.Tracing (Tracing, TracingConfig (..))++import Atelier.Effects.Conc qualified as Conc+import Atelier.Effects.Monitoring.Tracing qualified as Tracing+++-- | Run 'Conc' effect with automatic trace context propagation in a new scope.+runConc :: (Concurrent :> es, IOE :> es, Tracing :> es) => Eff (Conc : es) a -> Eff es a+runConc eff = withEffToIO concStrat $ \unlift ->+    Ki.scoped $ \scope ->+        unlift $ runConcTraced (Scope scope) eff+++-- | Run 'Conc' effect, selecting the interpreter based on tracing config.+--+-- If tracing is enabled, uses 'runConc' for automatic span link propagation.+-- If tracing is disabled, falls back to 'Conc.runConc' to skip the overhead.+runConcByConfig+    :: ( Concurrent :> es+       , IOE :> es+       , Reader TracingConfig :> es+       , Tracing :> es+       )+    => Eff (Conc : es) a -> Eff es a+runConcByConfig eff = do+    tracingEnabled <- asks @TracingConfig (.enabled)+    if tracingEnabled then runConc eff else Conc.runConc eff+++-- | Run 'Conc' effect with automatic trace context propagation.+--+-- All fork variants ('fork', 'fork_', 'forkTry') use span links, i.e. forked+-- threads start a fresh trace whose root spans carry a link back to the+-- originating span.+runConcTraced+    :: ( Concurrent :> es+       , IOE :> es+       , Tracing :> es+       )+    => Scope -> Eff (Conc : es) a -> Eff es a+runConcTraced scope = runConcBase scope . withConcTracingLinks+++-- | Intercept fork operations and wrap the forked action with span link propagation.+--+-- Re-dispatches to the underlying 'Conc' handler via 'fork', 'fork_', 'forkTry'.+withConcTracingLinks :: (Conc :> es, Tracing :> es) => Eff es a -> Eff es a+withConcTracingLinks = interpose \env -> \case+    Fork action -> tracedFork env action fork+    Fork_ action -> tracedFork env action fork_+    ForkTry action -> tracedFork env action forkTry+    other -> passthrough env other+  where+    tracedFork env action kiOp = do+        parentCtx <- Tracing.getSpanContext+        localUnlift env concStrat \unliftEff ->+            localLend @'[Tracing] env concStrat \lend ->+                kiOp+                    $ unliftEff+                        . lend+                        . Tracing.withLinkPropagation parentCtx+                        . raise @Tracing+                    $ action
+ src/Atelier/Effects/Console.hs view
@@ -0,0 +1,69 @@+-- | An effect for writing bytes and text to an output stream.+--+-- The single primitive is 'putStr' (raw bytes); 'putStrLn', 'putText' and+-- 'putTextLn' build on it. 'runConsole' writes to stdout, 'runConsoleHandle' to+-- any 'Handle', and 'runConsoleToList' captures output for tests.+module Atelier.Effects.Console+    ( -- * Effect+      Console+    , putStrLn+    , putStr+    , putTextLn+    , putText++      -- * Interpreters+    , runConsoleHandle+    , runConsole+    , runConsoleToList+    ) where++import Effectful (Effect, IOE)+import Effectful.Dispatch.Dynamic (interpret_, reinterpret_)+import Effectful.State.Static.Shared (modify, runState)+import Effectful.TH (makeEffect)+import System.IO (Handle, stdout)+import Prelude++import Data.ByteString.Char8 qualified as B8+++-- | Effect for writing output to a stream.+data Console :: Effect where+    -- | Write raw bytes to the output.+    PutStr :: ByteString -> Console m ()+++makeEffect ''Console+++-- | Write a 'ByteString' followed by a newline.+putStrLn :: (Console :> es) => ByteString -> Eff es ()+putStrLn = putStr . (<> "\n")+++-- | Write 'Text', encoded as UTF-8 bytes.+putText :: (Console :> es) => Text -> Eff es ()+putText = putStr . encodeUtf8+++-- | Write 'Text' as UTF-8 bytes, followed by a newline.+putTextLn :: (Console :> es) => Text -> Eff es ()+putTextLn = putStrLn . encodeUtf8+++-- | Interpret 'Console' by writing to the given 'Handle'.+runConsoleHandle :: (IOE :> es) => Handle -> Eff (Console : es) a -> Eff es a+runConsoleHandle h = interpret_ \case+    PutStr s -> liftIO $ B8.hPut h s+++-- | Interpret 'Console' by writing to 'stdout'.+runConsole :: (IOE :> es) => Eff (Console : es) a -> Eff es a+runConsole = runConsoleHandle stdout+++-- | Interpret 'Console' by collecting all writes into a list, in order. Useful+-- for asserting on output in tests.+runConsoleToList :: Eff (Console : es) a -> Eff es (a, [ByteString])+runConsoleToList = reinterpret_ (fmap (second reverse) . runState []) \case+    PutStr s -> modify (s :)
+ src/Atelier/Effects/Debounce.hs view
@@ -0,0 +1,181 @@+-- | Debounce effect for coalescing rapid bursts of keyed events.+--+-- == Overview+--+-- 'debouncedWith' is the fundamental operation: it accumulates rapid successive+-- calls with the same key using a merge function, then fires the callback once+-- after the settle window with the merged result.+--+-- 'debounced' is a convenience wrapper for the common case where only timing+-- matters and the last-registered action should fire.+--+-- == Example+--+-- @+-- -- Coalesce rapid saves per file: only the last edit within a 200ms window+-- -- triggers a rebuild, keyed by path.+-- onEdit :: (Debounce FilePath :> es) => FilePath -> Eff es ()+-- onEdit path = debounced 200 path (rebuild path)+--+-- -- Or merge the burst instead of keeping just the last value. Here every+-- -- event seen within the window is combined (list append) before a single+-- -- rebuild fires with the full batch.+-- onChange :: (Debounce FilePath :> es) => FilePath -> FileEvent -> Eff es ()+-- onChange path event =+--     debouncedWith 200 (<>) path [event] (rebuildWith path)+-- @+module Atelier.Effects.Debounce+    ( -- * Effect+      Debounce+    , debouncedWith+    , debounced++      -- * Interpreters+    , runDebounce+    , runDebounceNoOp++      -- * Helpers+    , ensureEntry+    , ensureCallback+    , Entry (..)+    ) where++import Data.Dynamic (Dynamic, fromDynamic, toDyn)+import Effectful (Effect, Limit (..), Persistence (..), UnliftStrategy (..))+import Effectful.Concurrent (Concurrent)+import Effectful.Concurrent.STM (STM)+import Effectful.Dispatch.Dynamic (interpretWith, localSeqUnlift, localUnlift)+import Effectful.TH (makeEffect)++import Effectful.Concurrent.STM qualified as STM+import StmContainers.Map qualified as Map++import Atelier.Effects.Conc (Conc)+import Atelier.Effects.Delay (Delay)+import Atelier.Time (Millisecond)++import Atelier.Effects.Conc qualified as Conc+import Atelier.Effects.Delay qualified as Delay+++-- | Effect for coalescing rapid bursts of keyed events into a single delayed+-- callback.+data Debounce key :: Effect where+    -- | Schedule @callback merged@ after the settle window. If another call+    -- with the same @key@ arrives before the window expires, the two values are+    -- combined with @merge old new@ and the timer resets. The callback fires at+    -- most once per burst.+    DebouncedWith+        :: (Typeable arg)+        => Millisecond+        -> (arg -> arg -> arg)+        -> key+        -> arg+        -> (arg -> m a)+        -> Debounce key m ()+++makeEffect ''Debounce+++-- | Schedule @action@ to run after the settle window unless a newer call with+-- the same @key@ arrives first. The last-registered action fires.+debounced :: (Debounce key :> es) => Millisecond -> key -> Eff es a -> Eff es ()+debounced settleMs key action = debouncedWith settleMs (\_ _ -> ()) key () (\_ -> action)+++-- | Per-key debounce state: the latest (merged) pending argument and a+-- generation counter used to tell whether a scheduled fire is still the most+-- recent call for that key.+data Entry = Entry+    { arg :: Maybe Dynamic+    -- ^ The latest pending argument (type-erased), or 'Nothing' once consumed.+    , generation :: Int+    -- ^ Counter bumped on every call for the key; identifies the latest one.+    }+++-- | Run the 'Debounce' effect.+--+-- Each key maintains a generation counter. Rapid calls for the same key merge+-- their values and reset the settle timer; only the last generation fires.+runDebounce+    :: forall key es a+     . ( Conc :> es+       , Concurrent :> es+       , Delay :> es+       , Hashable key+       )+    => Eff (Debounce key : es) a+    -> Eff es a+runDebounce eff = do+    state <- STM.atomically (Map.new @key @Entry)+    interpretWith eff \env -> \case+        DebouncedWith settleMs merge key arg callback -> do+            entry <- STM.atomically $ ensureEntry key arg state merge+            localUnlift env (ConcUnlift Persistent (Limited 1)) \unlift ->+                void+                    $ Conc.fork+                    $ ensureCallback settleMs state key entry.generation+                    $ unlift . callback+++-- | Sleep for @settleMs@, then atomically check whether this fork's+-- @generation@ is still the latest in the map for @key@. If yes, take the+-- (possibly merged) argument, remove the entry, and fire the callback. If a+-- newer call has bumped the generation in the meantime, exit silently.+ensureCallback+    :: forall key arg es a+     . ( Concurrent :> es+       , Delay :> es+       , Hashable key+       , Typeable arg+       )+    => Millisecond+    -> Map.Map key Entry+    -> key+    -> Int+    -> (arg -> Eff es a)+    -> Eff es ()+ensureCallback settleMs state key myGeneration callback = do+    Delay.wait settleMs+    fire <- STM.atomically do+        Map.lookup key state >>= \case+            Just e | e.generation == myGeneration -> do+                Map.delete key state+                pure $ fromDynamic =<< e.arg+            _ -> pure Nothing+    case fire of+        Just arg -> void $ callback arg+        Nothing -> pure ()+++ensureEntry+    :: (Hashable key, Typeable value)+    => key+    -> value+    -> Map.Map key Entry+    -> (value -> value -> value)+    -> STM Entry+ensureEntry key value state merge = do+    current <- Map.lookup key state+    let (gen, prior) = case current of+            Nothing -> (0, Nothing)+            Just e -> (e.generation + 1, e.arg >>= fromDynamic)+    let merged = case prior of+            Just p -> merge p value+            Nothing -> value+    let updatedEntry =+            Entry+                { arg = Just (toDyn merged)+                , generation = gen+                }+    Map.insert updatedEntry key state+    pure updatedEntry+++-- | No-op interpreter — fires every callback immediately with its value, without+-- debouncing. Useful for tests where timing is controlled externally.+runDebounceNoOp :: Eff (Debounce key : es) a -> Eff es a+runDebounceNoOp eff = interpretWith eff \env -> \case+    DebouncedWith _ _ _ value callback -> localSeqUnlift env \unlift -> void $ unlift (callback value)
+ src/Atelier/Effects/Delay.hs view
@@ -0,0 +1,56 @@+-- | An effect for delaying execution.+--+-- 'wait' suspends the current thread for a 'TimeUnit' duration; 'every' repeats+-- an action forever with a fixed gap between runs. 'runDelay' performs real+-- delays, while 'runDelayNoOp' skips them so time-based code runs instantly+-- under test.+--+-- @+-- -- pause within a workflow:+-- wait (250 :: Millisecond)+--+-- -- run a health check every 30 seconds, forever (the caller forks it):+-- fork_ $ every (30 :: Second) checkHealth+-- @+module Atelier.Effects.Delay+    ( Delay+    , wait+    , every+    , runDelay+    , runDelayNoOp+    ) where++import Data.Time.Units (TimeUnit, toMicroseconds)+import Effectful (Effect)+import Effectful.Concurrent (Concurrent, threadDelay)+import Effectful.Dispatch.Dynamic (interpret_)+import Effectful.TH (makeEffect)+++-- | Effect for suspending execution for a given duration.+data Delay :: Effect where+    -- | Halt the thread and wait for the passed duration before continuing.+    Wait :: (TimeUnit t) => t -> Delay m ()+++makeEffect ''Delay+++-- | Runs an action repeatedly, waiting the given duration in between each+-- execution, starting immediately. Returns Void since it runs forever.+-- Caller is responsible for forking.+every :: (Delay :> es, TimeUnit t) => t -> Eff es () -> Eff es Void+every delay action = forever do+    action+    wait delay+++-- | Interpret 'Delay' using real thread delays.+runDelay :: (Concurrent :> es) => Eff (Delay : es) a -> Eff es a+runDelay = interpret_ \(Wait delay) ->+    threadDelay $ fromIntegral (toMicroseconds delay)+++-- | Delay interpreter that makes every 'wait' a no-op — useful in unit tests.+runDelayNoOp :: Eff (Delay : es) a -> Eff es a+runDelayNoOp = interpret_ \(Wait _) -> pure ()
+ src/Atelier/Effects/Env.hs view
@@ -0,0 +1,35 @@+-- | An effect for reading process environment variables.+--+-- 'runEnv' reads the real process environment; 'runEnvConst' supplies a fixed+-- association list for tests.+module Atelier.Effects.Env+    ( Env+    , getEnvironment+    , runEnv+    , runEnvConst+    ) where++import Effectful (Effect, IOE)+import Effectful.Dispatch.Dynamic (interpret_)+import Effectful.TH (makeEffect)++import System.Environment qualified as System+++-- | Effect for reading the process environment.+data Env :: Effect where+    -- | The full environment as a list of @(name, value)@ pairs.+    GetEnvironment :: Env m [(String, String)]+++makeEffect ''Env+++-- | Interpret 'Env' against the real process environment.+runEnv :: (IOE :> es) => Eff (Env : es) a -> Eff es a+runEnv = interpret_ $ \GetEnvironment -> liftIO System.getEnvironment+++-- | Interpret 'Env' with a fixed environment, for tests.+runEnvConst :: [(String, String)] -> Eff (Env : es) a -> Eff es a+runEnvConst env = interpret_ $ \GetEnvironment -> pure env
+ src/Atelier/Effects/Exit.hs view
@@ -0,0 +1,55 @@+-- | An effect for terminating the program with an exit code.+--+-- 'runExit' really exits the process; 'runExitNoOp' captures the exit code+-- instead, so tests can assert on it without killing the test runner.+module Atelier.Effects.Exit+    ( -- * Effect+      Exit+    , exitWith+    , exitSuccess+    , exitFailure++      -- * Interpreters+    , runExit+    , runExitNoOp+    ) where++import Effectful (Effect, IOE)+import Effectful.Dispatch.Dynamic (interpret_, reinterpret_)+import Effectful.Error.Static (runErrorNoCallStack, throwError)+import Effectful.TH (makeEffect)+import System.Exit (ExitCode (..))++import System.Exit qualified as IO+++-- | Effect for terminating the program with an exit code.+data Exit :: Effect where+    -- | Terminate the program with the given 'ExitCode'. Does not return.+    ExitWith :: ExitCode -> Exit m a+++makeEffect ''Exit+++-- | Exit the program successfully (exit code 0).+exitSuccess :: (Exit :> es) => Eff es a+exitSuccess = exitWith ExitSuccess+++-- | Exit the program with a generic failure (exit code 1).+exitFailure :: (Exit :> es) => Eff es a+exitFailure = exitWith (ExitFailure 1)+++-- | Interpret 'Exit' by actually terminating the process.+runExit :: (IOE :> es) => Eff (Exit : es) a -> Eff es a+runExit = interpret_ \(ExitWith code) -> liftIO (IO.exitWith code)+++-- | Exit interpreter that captures exit calls instead of terminating the process.+-- Returns 'Left' the exit code if the action exited, 'Right' the result otherwise.+-- Useful in unit tests.+runExitNoOp :: Eff (Exit : es) a -> Eff es (Either ExitCode a)+runExitNoOp =+    reinterpret_ (runErrorNoCallStack @ExitCode) \(ExitWith code) -> throwError code
+ src/Atelier/Effects/File.hs view
@@ -0,0 +1,103 @@+{-# OPTIONS_GHC -Wno-redundant-constraints #-}++-- | A handle-based file IO effect.+--+-- A thin 'Eff' wrapper over the handle operations in "System.IO" and+-- "Data.Text.IO" ('withFile', 'hPutText', 'hGetLine', …), so file IO passes+-- through the effect system instead of raw 'IO'. 'Handle' and 'BufferMode' are+-- re-exported for convenience.+module Atelier.Effects.File+    ( File+    , Handle+    , BufferMode (..)+    , withFile+    , hClose+    , hFlush+    , hGetLine+    , hPutText+    , hPutTextLn+    , hPutLBs+    , hPutLBsLn+    , hIsEOF+    , hSetBuffering+    , runFile+    ) where++import Effectful (Dispatch (..), DispatchOf, Effect, IOE)+import Effectful.Dispatch.Static+    ( SideEffects (..)+    , StaticRep+    , evalStaticRep+    , unsafeEff_+    , unsafeSeqUnliftIO+    )+import System.IO (BufferMode (..), Handle)+import Prelude++import Data.ByteString.Lazy.Char8 qualified as LB8+import Data.Text.IO qualified as TIO+import System.IO qualified as IO+++-- | Operations concerning file handles.+data File :: Effect+++type instance DispatchOf File = Static WithSideEffects+data instance StaticRep File = File+++-- | Lifted `System.IO.withFile`:+withFile :: (File :> es, HasCallStack) => FilePath -> IOMode -> (Handle -> Eff es a) -> Eff es a+withFile fp m f = unsafeSeqUnliftIO \unlift -> IO.withFile fp m (unlift . f)+++-- | Lifted `System.IO.hClose`.+hClose :: (File :> es, HasCallStack) => Handle -> Eff es ()+hClose = unsafeEff_ . IO.hClose+++-- | Lifted `System.IO.hFlush`.+hFlush :: (File :> es, HasCallStack) => Handle -> Eff es ()+hFlush = unsafeEff_ . IO.hFlush+++-- | Lifted `System.IO.hGetLine`.+hGetLine :: (File :> es, HasCallStack) => Handle -> Eff es Text+hGetLine = unsafeEff_ . fmap toText . IO.hGetLine+++-- | Lifted `Data.Text.IO.hPutStr`. Encodes via the handle's text encoding,+-- symmetric with `hGetLine`.+hPutText :: (File :> es, HasCallStack) => Handle -> Text -> Eff es ()+hPutText h = unsafeEff_ . TIO.hPutStr h+++-- | `hPutText` with a `\n` at the end.+hPutTextLn :: (File :> es, HasCallStack) => Handle -> Text -> Eff es ()+hPutTextLn h = unsafeEff_ . TIO.hPutStrLn h+++-- | Lifted `System.IO.hIsEOF`.+hIsEOF :: (File :> es, HasCallStack) => Handle -> Eff es Bool+hIsEOF = unsafeEff_ . IO.hIsEOF+++-- | Lifted `Data.ByteString.Lazy.Char8.hPutStr`.+hPutLBs :: (File :> es, HasCallStack) => Handle -> LByteString -> Eff es ()+hPutLBs h s = unsafeEff_ $ LB8.hPutStr h s+++-- | Lifted `System.IO.hSetBuffering`.+hSetBuffering :: (File :> es, HasCallStack) => Handle -> BufferMode -> Eff es ()+hSetBuffering h m = unsafeEff_ $ IO.hSetBuffering h m+++-- | `hPutLBs` with a `\n` at the end.+hPutLBsLn :: (File :> es, HasCallStack) => Handle -> LByteString -> Eff es ()+hPutLBsLn h = hPutLBs h . (<> "\n")+++-- | Run file operations.+runFile :: (HasCallStack, IOE :> es) => Eff (File : es) a -> Eff es a+runFile = evalStaticRep File
+ src/Atelier/Effects/FileSystem.hs view
@@ -0,0 +1,158 @@+-- | An effect for filesystem operations: reading files, listing and creating+-- directories, and querying paths.+--+-- 'runFileSystemIO' performs real filesystem IO; 'runFileSystemNoOp' returns+-- inert results; and 'runFileSystemState' simulates a filesystem backed by an+-- in-memory 'Map' for tests. 'followFile' tails a file as it grows.+module Atelier.Effects.FileSystem+    ( FileSystem (..)+    , readFileBs+    , readFileLbsFrom+    , readFileLbs+    , followFile+    , doesFileExist+    , doesPathExist+    , listDirectory+    , createDirectoryIfMissing+    , removeFile+    , canonicalizePath+    , getCurrentDirectory+    , getXdgRuntimeDir+    , runFileSystemIO+    , runFileSystemNoOp+    , runFileSystemState+    ) where++import Control.Exception (bracket)+import Effectful (Effect, IOE)+import Effectful.Dispatch.Dynamic (interpret_)+import Effectful.Exception (throwIO)+import Effectful.State.Static.Shared (State, gets, modify)+import Effectful.TH (makeEffect)+import System.Environment (lookupEnv)+import System.IO.Error (userError)+import System.Posix.Types (COff (..), FileOffset)++import Data.ByteString qualified as BS+import Data.ByteString.Lazy qualified as LBS+import Data.Map.Strict qualified as M+import System.Directory qualified as Dir+import System.Posix.IO qualified as Posix++import Atelier.Effects.Delay (Delay)+import Atelier.Effects.Posix.IO (readFdFrom)+import Atelier.Time (Millisecond)++import Atelier.Effects.Delay qualified as Delay+++-- | Effect for filesystem access.+data FileSystem :: Effect where+    -- | Read a file's full contents strictly.+    ReadFileBs :: FilePath -> FileSystem m ByteString+    -- | Read a file from the given byte offset to the end, lazily.+    ReadFileLbsFrom :: FilePath -> FileOffset -> FileSystem m LBS.ByteString+    -- | Does a regular file exist at the path?+    DoesFileExist :: FilePath -> FileSystem m Bool+    -- | Does anything (file or directory) exist at the path?+    DoesPathExist :: FilePath -> FileSystem m Bool+    -- | List the entries of a directory.+    ListDirectory :: FilePath -> FileSystem m [FilePath]+    -- | Create a directory. The 'Bool' requests creation of missing parents.+    CreateDirectoryIfMissing :: Bool -> FilePath -> FileSystem m ()+    -- | Delete a file.+    RemoveFile :: FilePath -> FileSystem m ()+    -- | Resolve a path to a canonical, absolute form.+    CanonicalizePath :: FilePath -> FileSystem m FilePath+    -- | The process's current working directory.+    GetCurrentDirectory :: FileSystem m FilePath+    -- | The XDG runtime directory (@$XDG_RUNTIME_DIR@), falling back to @\/tmp@.+    GetXdgRuntimeDir :: FileSystem m FilePath+++makeEffect ''FileSystem+++-- | Read a file's full contents lazily (equivalent to reading from offset 0).+readFileLbs :: (FileSystem :> es) => FilePath -> Eff es LBS.ByteString+readFileLbs path = readFileLbsFrom path 0+++-- | Follow a file as it grows, calling @onChunk@ with each new chunk of+-- content. Polls every 200ms. Does not return.+followFile+    :: (Delay :> es, FileSystem :> es)+    => FilePath+    -> (ByteString -> Eff es ())+    -> Eff es a+followFile path onChunk = go 0+  where+    go offset = do+        newContent <- readFileLbsFrom path offset+        if LBS.null newContent then pure () else onChunk (LBS.toStrict newContent)+        Delay.wait (200 :: Millisecond)+        go (offset + fromIntegral (LBS.length newContent))+++-- | Interpret 'FileSystem' against the real filesystem.+runFileSystemIO :: (IOE :> es) => Eff (FileSystem : es) a -> Eff es a+runFileSystemIO = interpret_ $ \case+    ReadFileBs path -> liftIO $ BS.readFile path+    ReadFileLbsFrom path offset ->+        liftIO+            $ bracket+                (Posix.openFd path Posix.ReadOnly Posix.defaultFileFlags)+                Posix.closeFd+                (readFdFrom offset)+    DoesFileExist path -> liftIO $ Dir.doesFileExist path+    DoesPathExist path -> liftIO $ Dir.doesPathExist path+    ListDirectory path -> liftIO $ Dir.listDirectory path+    CreateDirectoryIfMissing p path -> liftIO $ Dir.createDirectoryIfMissing p path+    RemoveFile path -> liftIO $ Dir.removeFile path+    CanonicalizePath path -> liftIO $ Dir.canonicalizePath path+    GetCurrentDirectory -> liftIO Dir.getCurrentDirectory+    GetXdgRuntimeDir -> liftIO $ fromMaybe "/tmp" <$> lookupEnv "XDG_RUNTIME_DIR"+++-- | Interpret 'FileSystem' with inert results: reads return empty, existence+-- checks return 'False', and mutations do nothing. Useful for tests.+runFileSystemNoOp :: Eff (FileSystem : es) a -> Eff es a+runFileSystemNoOp = interpret_ $ \case+    ReadFileBs _ -> pure mempty+    ReadFileLbsFrom _ _ -> pure mempty+    DoesFileExist _ -> pure False+    DoesPathExist _ -> pure False+    ListDirectory _ -> pure []+    CreateDirectoryIfMissing _ _ -> pure ()+    RemoveFile _ -> pure ()+    CanonicalizePath path -> pure path+    GetCurrentDirectory -> pure "."+    GetXdgRuntimeDir -> pure "/tmp"+++-- | Run `FileSystem` effect backed by a `State` effect with a `Map`. The keys+-- of the `Map` are treated as file names. Only the `dirname` of files are+-- counted as existing directories.+runFileSystemState+    :: (State (Map FilePath ByteString) :> es)+    => Eff (FileSystem : es) a -> Eff es a+runFileSystemState = interpret_ \case+    ReadFileBs fp ->+        maybe (throwIO $ userError "No such file") pure+            =<< gets (M.lookup fp)+    ReadFileLbsFrom fp (COff offset) -> do+        contents <-+            maybe (throwIO $ userError "No such file") pure+                =<< gets (M.lookup fp)+        pure+            . toLazy+            . BS.drop (fromIntegral offset)+            $ contents+    DoesFileExist fp -> gets $ M.member fp+    DoesPathExist fp -> gets $ any (\p -> fp `isPrefixOf` p && fp /= p) . M.keys+    ListDirectory fp -> gets $ filter (\p -> fp `isPrefixOf` p && fp /= p) . M.keys+    CreateDirectoryIfMissing _ _ -> pure ()+    RemoveFile fp -> modify $ M.delete fp+    CanonicalizePath fp -> pure fp+    GetCurrentDirectory -> pure "/"+    GetXdgRuntimeDir -> pure "/tmp"
+ src/Atelier/Effects/FileWatcher.hs view
@@ -0,0 +1,247 @@+-- | Effect and smart constructors for watching file system paths.+--+-- == Overview+--+-- Build a list of 'Watch' values describing what to observe, then pass them+-- to 'watchFilePaths'. The effect registers the OS-level watchers needed to+-- cover the list (deduplication by path prefix) and fires the callback at most+-- once per raw filesystem event for a path.+--+-- == Examples+--+-- Watch a source directory for Haskell files, ignoring build artefacts:+--+-- @+-- watchFilePaths [dirExt "src" ".hs" \`excluding\` containing "dist-newstyle"] callback+-- @+--+-- Watch source and test directories together:+--+-- @+-- watchFilePaths (map (\`dirExt\` ".hs") ["src", "test"]) callback+-- @+--+-- Watch cabal-related files anywhere under a project root:+--+-- @+-- watchFilePaths [dirWhere projectRoot isCabalFile] callback+--   where+--     isCabalFile f = takeExtension f == ".cabal"+--                  || takeFileName f \`elem\` ["cabal.project", "package.yaml"]+-- @+--+-- Combine source and cabal watches with a single callback that dispatches on+-- the path, with automatic debouncing:+--+-- @+-- watchFilePathsDebounced (sourceWatches ++ cabalWatches) (markDirty . changeKindFor)+-- @+module Atelier.Effects.FileWatcher+    ( -- * Watch specification+      Watch++      -- ** Constructors+    , dir+    , dirExt+    , dirWhere++      -- ** Combinators+    , excluding+    , containing++      -- * File events+    , FileEvent (..)+    , mergeFileEvent++      -- * Effect+    , FileWatcher+    , watchFilePaths+    , watchFilePathsDebounced++      -- * Interpreters+    , runFileWatcherIO+    , runFileWatcherScripted++      -- * Internals (exported for testing)+    , deduplicateDirs+    , matchesAny+    ) where++import Control.Concurrent (threadDelay)+import Control.Concurrent.STM (retry)+import Data.List (nub)+import Effectful (Effect, IOE)+import Effectful.Concurrent (Concurrent)+import Effectful.Concurrent.STM (atomically)+import Effectful.Dispatch.Dynamic (interpretWith, localSeqUnlift, localUnliftIO, reinterpret)+import Effectful.State.Static.Shared (evalState, get, put)+import Effectful.TH (makeEffect)+import System.Directory (makeAbsolute)+import System.FSNotify (eventPath, watchTree, withManager)+import System.FilePath (takeExtension)++import Data.Text qualified as T+import System.FSNotify qualified as FSN++import Atelier.Effects.Conc (concStrat)+import Atelier.Effects.Debounce (Debounce, debouncedWith)+++-- | The kind of filesystem change that triggered a watch callback.+data FileEvent+    = -- | A new file was created.+      Added+    | -- | An existing file was modified.+      Modified+    | -- | A file was deleted.+      Removed+    deriving stock (Eq, Show)+++-- | Merge two 'FileEvent's for the same path within a debounce window.+--+-- Rules (old, new) → result:+--+-- * @(_, Removed)@ → @Removed@: deletion always wins.+-- * @(Removed, Added)@ → @Added@: explicit re-creation after deletion.+-- * @(Added, _)@ → @Added@: a create-then-write is still a creation.+-- * Otherwise → the newer event.+mergeFileEvent :: FileEvent -> FileEvent -> FileEvent+mergeFileEvent _ Removed = Removed+mergeFileEvent Removed Added = Added+mergeFileEvent Added _ = Added+mergeFileEvent _ event = event+++-- | Specification of a directory to watch recursively, with a file predicate.+data Watch = Watch FilePath (FilePath -> Bool)+++-- | Watch all files in a directory recursively.+dir :: FilePath -> Watch+dir p = Watch p (const True)+++-- | Watch files matching a predicate in a directory recursively.+--+-- @+-- dirWhere "src" (\f -> takeExtension f == ".hs")+-- @+dirWhere :: FilePath -> (FilePath -> Bool) -> Watch+dirWhere = Watch+++-- | Watch files with a specific extension in a directory recursively.+--+-- @+-- dirExt "src" ".hs"+-- @+dirExt :: FilePath -> Text -> Watch+dirExt p ext = dirWhere p (\f -> toText (takeExtension f) == ext)+++-- | Narrow a 'Watch' to exclude files matching a predicate.+--+-- @+-- dirExt "src" ".hs" \`excluding\` containing "dist-newstyle"+-- @+excluding :: Watch -> (FilePath -> Bool) -> Watch+excluding (Watch p predicate) excl = Watch p (\f -> predicate f && not (excl f))+++-- | Predicate: the file path contains the given fragment.+--+-- Intended for use with 'excluding':+--+-- @+-- dir "src" \`excluding\` containing "dist-newstyle"+-- @+containing :: Text -> FilePath -> Bool+containing fragment f = fragment `T.isInfixOf` toText f+++data FileWatcher :: Effect where+    -- | Watch the given directories for changes, calling the callback with+    -- each matching file path and the kind of change that occurred. Registers+    -- the minimal set of OS watchers needed to cover all entries (deduplication+    -- by path prefix). The callback is invoked at most once per raw filesystem+    -- event regardless of how many entries match. Never returns.+    WatchFilePaths :: [Watch] -> (FilePath -> FileEvent -> m a) -> FileWatcher m Void+++makeEffect ''FileWatcher+++-- | Like 'watchFilePaths' but automatically debounces by path.+-- Rapid successive events for the same file coalesce into a single callback.+-- Uses a 100ms settle window.+watchFilePathsDebounced+    :: (Debounce FilePath :> es, FileWatcher :> es)+    => [Watch]+    -> (FilePath -> FileEvent -> Eff es ())+    -> Eff es Void+watchFilePathsDebounced watches callback =+    watchFilePaths watches \path event ->+        debouncedWith 100 mergeFileEvent path event (callback path)+++-- | Production interpreter backed by fsnotify.+runFileWatcherIO :: (IOE :> es) => Eff (FileWatcher : es) a -> Eff es a+runFileWatcherIO eff = interpretWith eff \env -> \case+    WatchFilePaths watches callback ->+        localUnliftIO env concStrat \unliftIO -> do+            absWatches <- forM watches \(Watch p predicate) ->+                (\absP -> Watch absP predicate) <$> makeAbsolute p+            withManager \mgr -> do+                let dedupedDirs = deduplicateDirs [p | Watch p _ <- absWatches]+                for_ dedupedDirs \d ->+                    watchTree mgr d (matchesAny absWatches . eventPath) \fsEvent ->+                        void $ unliftIO $ callback (eventPath fsEvent) (toFileEvent fsEvent)+                forever $ threadDelay 1_000_000+++-- | Scripted interpreter for testing.+-- Delivers all scripted events to the callback in order, then blocks+-- indefinitely — matching the blocking semantics of 'runFileWatcherIO'.+-- The 'Watch' specification is ignored; the caller controls what events are fed in.+runFileWatcherScripted :: (Concurrent :> es) => [(FilePath, FileEvent)] -> Eff (FileWatcher : es) a -> Eff es a+runFileWatcherScripted events = reinterpret (evalState events) \env -> \case+    WatchFilePaths _ callback ->+        localSeqUnlift env \unlift -> do+            events' <- get+            put []+            for_ events' \(path, fileEvent) -> unlift $ callback path fileEvent+            atomically retry+++-- Helpers++toFileEvent :: FSN.Event -> FileEvent+toFileEvent = \case+    FSN.Added {} -> Added+    FSN.Modified {} -> Modified+    FSN.ModifiedAttributes {} -> Modified+    FSN.CloseWrite {} -> Modified+    FSN.Removed {} -> Removed+    FSN.WatchedDirectoryRemoved {} -> Removed+    FSN.Unknown {} -> Modified+++-- | Remove dirs that are proper subdirectories of another dir in the list.+deduplicateDirs :: [FilePath] -> [FilePath]+deduplicateDirs dirs = filter notRedundant (nub dirs)+  where+    notRedundant d = not $ any (\d' -> d' /= d && isStrictAncestor d' d) dirs+++-- | @isStrictAncestor parent child@ is true iff @parent@ is a proper ancestor+-- of @child@ in the filesystem hierarchy.+isStrictAncestor :: FilePath -> FilePath -> Bool+isStrictAncestor parent child = (parent <> "/") `isPrefixOf` child+++-- | Check whether a file path matches at least one 'Watch' entry.+matchesAny :: [Watch] -> FilePath -> Bool+matchesAny watches path = any matches watches+  where+    matches (Watch d predicate) = (d == path || isStrictAncestor d path) && predicate path
+ src/Atelier/Effects/Input.hs view
@@ -0,0 +1,47 @@+-- | An effect for requesting a value from the environment on each call.+--+-- Unlike 'Effectful.Reader.Static.Reader', 'Input' makes no assumption that the+-- value is stable across the computation — each 'input' may observe a different+-- value. See the 'Input' type below for the full comparison.+module Atelier.Effects.Input+    ( Input+    , input+    , runInputEff+    , runInputConst+    ) where++import Effectful (Effect)+import Effectful.Dispatch.Dynamic (interpret_)+import Effectful.TH (makeEffect)+++-- | Request a value from the effect system.+--+-- This effect does not carry any+-- semantics as to how the value is created, whether it is cached, or whether+-- you get a different value for each call. It is similar to+-- 'Effectful.Reader.Static.Reader' in that it is about requesting a value, but+-- 'Reader' carries the implicit assumption that its value remains static for+-- the duration of the encapsulated computation, while 'Input' carries no such+-- assumption.+--+-- If the value you wish to request from the effect system will remain+-- unchanged for the duration of the computation, use 'Effectful.Reader.Static'+-- or 'Effectful.Reader.Local' instead.+data Input i :: Effect where+    Input :: Input i m i+++makeEffect ''Input+++-- | 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+++-- | 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
+ src/Atelier/Effects/Internal/Coroutine.hs view
@@ -0,0 +1,225 @@+-- | Internal: the shared implementation of the 'Yield' and 'Await' coroutine+-- effects.+--+-- Both effects, along with their operations and interpreters, are defined here;+-- "Atelier.Effects.Yield" and "Atelier.Effects.Await" re-export curated subsets+-- for public use. Exposed chiefly for testing — prefer the public modules.+module Atelier.Effects.Internal.Coroutine+    ( -- * Yield+      Yield (..)++      -- ** Operations+    , yield+    , inFoldable+    , yieldEvents+    , cycleToYield++      -- ** Interpreters+    , forEach+    , yieldToList+    , yieldToReverseList+    , withYieldToList+    , ignoreYield+    , enumerate+    , enumerateFrom+    , map+    , mapMaybe+    , catMaybes++      -- * Await+    , Await (..)++      -- ** Operations+    , await++      -- ** Interpreters+    , eachAwait++      -- * Shared++      -- ** Operations+    , takeAwait++      -- ** Interpreters+    , awaitYield+    ) where++import Effectful (Effect, UnliftStrategy (..), inject, raiseWith)+import Effectful.Dispatch.Dynamic (interpretWith_, interpret_, reinterpretWith_, reinterpret_)+import Effectful.State.Static.Shared (evalState, get, modify, runState, state)+import Effectful.TH (makeEffect)+import Prelude hiding (catMaybes, map, mapMaybe)++import Atelier.Effects.Chan (Chan)+import Atelier.Effects.Conc (Conc)+import Atelier.Effects.Publishing (Sub)++import Atelier.Effects.Chan qualified as Chan+import Atelier.Effects.Conc qualified as Conc+import Atelier.Effects.Publishing qualified as Sub+++-- * Yield+++-- | Yield values to the effect system. The producing side of the+-- 'Yield'/'Await' pair. Analogous to 'Writer' and 'Output' effects.+data Yield a :: Effect where+    Yield :: a -> Yield a m ()+++makeEffect ''Yield+++-- ** Yield operations+++-- | 'Yield' all elements of a foldable.+inFoldable :: forall a t es. (Foldable t, Yield a :> es) => t a -> Eff es ()+inFoldable =+    foldl'+        ( \prev x -> do+            prev+            yield x+        )+        (pure ())+++-- | 'Yield' all elements of a foldable, cycling it 'forever'.+cycleToYield :: forall a f es. (Foldable f, Yield a :> es) => f a -> Eff es ()+cycleToYield = forever . inFoldable+++-- | 'Yield' all events captured from a 'Sub' effect.+yieldEvents :: forall a es. (Conc :> es, Sub a :> es, Yield a :> es) => Eff es ()+yieldEvents = Conc.scoped do+    Conc.fork_ $ Sub.listen_ yield+    pure ()+++-- ** Yield interpreters+++-- | Perform an action for each value of a 'Yield' stream.+forEach :: (a -> Eff es b) -> Eff (Yield a : es) r -> Eff es r+forEach f = interpret_ \(Yield x) -> void $ f x+++-- | Collect all 'Yield'ed values into a list.+yieldToList :: Eff (Yield a : es) r -> Eff es (r, [a])+yieldToList = fmap (second reverse) . yieldToReverseList+++-- | Collect all 'Yield'ed values into a list. This function is more optimal to+-- use than 'yieldToList' if the reversed order is acceptable.+yieldToReverseList :: Eff (Yield a : es) r -> Eff es (r, [a])+yieldToReverseList = reinterpret_ (runState []) \(Yield x) -> modify (x :)+++-- | Allows a computation to 'Yield' values before performing a function over+-- the 'yield'ed values as a list.+withYieldToList :: Eff (Yield a : es) ([a] -> r) -> Eff es r+withYieldToList act = evalState [] do+    f <- interpretWith_ (inject act) \(Yield x) -> modify (x :)+    xs <- get+    pure $ f $ reverse xs+++-- | Ignore all 'Yield'ed values, discarding them.+ignoreYield :: Eff (Yield a : es) r -> Eff es r+ignoreYield = interpret_ \(Yield _) -> pure ()+++-- | Pair each 'Yield'ed value with its index in the sequence of yielded+-- values.+enumerate :: Eff (Yield a : es) r -> Eff (Yield (Int, a) : es) r+enumerate = enumerateFrom 0+++-- | Pair each 'Yield'ed value with its index in the sequence of yielded+-- values, starting from `initial`.+enumerateFrom :: Int -> Eff (Yield a : es) r -> Eff (Yield (Int, a) : es) r+enumerateFrom initial act = raiseWith SeqUnlift \unlift ->+    reinterpretWith_ (evalState initial) act \(Yield x) -> do+        i <- state \s -> (s, s + 1)+        inject $ unlift $ yield (i, x)+++-- | Map a 'Yield' stream of values into a different 'Yield' stream of values.+-- The consumed stream will not be visible to downstream computations, and the+-- produced stream will not be visible to upstream computations.+map :: (a -> b) -> Eff (Yield a : es) r -> Eff (Yield b : es) r+map f act = raiseWith SeqUnlift \unlift ->+    interpretWith_ act \(Yield x) -> unlift $ yield $ f x+++-- | Map a 'Yield'  stream of values. Values returned as 'Just' will be+-- included in the resulting 'Yield' stream. Values returned as 'Nothing' will+-- be discarded.+mapMaybe :: (a -> Maybe b) -> Eff (Yield a : es) r -> Eff (Yield b : es) r+mapMaybe f act =+    raiseWith SeqUnlift \unlift -> interpretWith_ act \(Yield x) ->+        case f x of+            Just y -> unlift $ yield y+            Nothing -> pure ()+++-- | Eliminate 'Nothing's from a 'Yield' stream, resulting in a 'Yield' stream+-- with all the 'Just' values.+catMaybes :: Eff (Yield (Maybe a) : es) r -> Eff (Yield a : es) r+catMaybes act = raiseWith SeqUnlift \unlift -> interpretWith_ act \case+    Yield (Just x) -> unlift $ yield x+    Yield Nothing -> pure ()+++-- * Await+++-- | Request a value from the effect system. The consuming side of the+-- 'Yield'/'Await' pair. Analogous to 'Reader' and 'Input'.+data Await a :: Effect where+    Await :: Await a m a+++makeEffect ''Await+++-- ** Await operations+++-- | Take 'n' values from an 'Await' effect and re-'yield' them to a new+-- 'Yield' event.+--+-- This operation is of dubious value given how Effectful's effect system+-- works, but it is included here for brevity's sake.+takeAwait :: (Await a :> es, Yield a :> es) => Int -> Eff es ()+takeAwait 0 = pure ()+takeAwait c = do+    await >>= yield+    takeAwait (c - 1)+++-- ** Await interpreters+++-- | Answers each `Await` with the passed action's result.+eachAwait :: forall a es r. Eff es a -> Eff (Await a : es) r -> Eff es r+eachAwait mk = interpret_ \Await -> mk+++-- | Supplies the `Await` effect of one computation with the `Yield` effect of+-- another.+awaitYield+    :: forall a es r+     . (Chan :> es, Conc :> es)+    => Eff (Yield a : es) r+    -> Eff (Await a : es) r+    -> Eff es r+awaitYield yields awaits = Conc.scoped do+    (inChan, outChan) <- Chan.newChan @a+    let yielder = interpretWith_ yields \(Yield x) -> Chan.writeChan inChan x+        awaiter = interpretWith_ awaits \Await -> Chan.readChan outChan+    -- Ensure the awaiter runs first.+    awaitThread <- Conc.fork awaiter+    yieldThread <- Conc.fork yielder+    either id id <$> Conc.race (Conc.await awaitThread) (Conc.await yieldThread)
+ src/Atelier/Effects/Iterator.hs view
@@ -0,0 +1,69 @@+-- | A pull-based iterator over a (possibly infinite) stream of values.+--+-- Where the 'Yield' effect pushes values to a consumer, an 'Iterator' is pulled+-- one value at a time with 'next'. 'fromEvents' adapts a 'Sub' event source into+-- an iterator with a buffered, race-free subscription, and a stream can be+-- narrowed with 'filter' and 'changes'.+module Atelier.Effects.Iterator+    ( Iterator+    , next+    , fromEvents+    , filter+    , changes+    ) where++import Effectful.Concurrent (Concurrent)+import Prelude hiding (filter)++import Atelier.Effects.Chan (Chan)+import Atelier.Effects.Conc (Conc)+import Atelier.Effects.Publishing (Sub)++import Atelier.Effects.Chan qualified as Chan+import Atelier.Effects.Conc qualified as Conc+import Atelier.Effects.Publishing qualified as Sub+++-- | A pull-based iterator of (potentially infinite) values.+newtype Iterator es a = Iterator+    { next :: Eff es a+    -- ^ Pull the next value from the iterator, performing whatever effects that+    -- requires.+    }+    deriving (Functor) via (Eff es)+++-- | Run a continuation with a buffered iterator of 'Sub' events. The iterator+-- subscribes before the continuation runs, so no events are missed: we use+-- 'Sub.forkListener_', which forks the listener and blocks until it has+-- actually subscribed before returning. Without that barrier the subscription+-- races a publisher started inside @use@, which under scheduler pressure can+-- drop early events and wedge 'next' forever. The listener thread is scoped to+-- the continuation and is killed when it returns.+fromEvents+    :: forall event es a+     . (Chan :> es, Conc :> es, Concurrent :> es, Sub event :> es)+    => (Iterator es event -> Eff es a)+    -> Eff es a+fromEvents use = Conc.scoped do+    (inChan, outChan) <- Chan.newChan+    Sub.forkListener_ (Chan.writeChan inChan)+    use $ Iterator (Chan.readChan outChan)+++-- | Iterate only over values that pass a predicate.+filter :: (a -> Bool) -> Iterator es a -> Iterator es a+filter p (Iterator n) = Iterator loop+  where+    loop = do+        x <- n+        if p x then pure x else loop+++-- | Iterate only values that differ from the previous one.+changes :: (Eq a) => a -> Iterator es a -> Iterator es a+changes initial iterator = Iterator (loop initial)+  where+    loop prev = do+        x <- next (filter (/= prev) iterator)+        pure x
+ src/Atelier/Effects/Log.hs view
@@ -0,0 +1,245 @@+-- | Log effect with hierarchical namespace support.+--+-- Provides structured logging with composable namespaces for better organization.+--+-- == Basic Usage+--+-- @+-- myComponent :: (Log :> es) => Eff es ()+-- myComponent = do+--     info "Starting component"+--     -- Logs: [INFO] [MyModule.myComponent#42] Starting component+-- @+--+-- == Using Namespaces+--+-- @+-- processData :: (Log :> es) => Eff es ()+-- processData = withNamespace "processor" $ do+--     info "Processing started"+--     -- Logs: [INFO] [processor] [MyModule.processData#10] Processing started+--+--     withNamespace "validation" $ do+--         info "Validating input"+--         -- Logs: [INFO] [processor.validation] [MyModule.processData#13] Validating input+-- @+module Atelier.Effects.Log+    ( -- * Effect+      Log+    , Message (..)+    , Config (..)+    , Severity (..)+    , log+    , info+    , warn+    , debug+    , err+    , withNamespace++      -- * Interpreters+    , runLog+    , runLogNoOp+    , runLogToHandle+    , runLogWriter+    ) where++import Data.Aeson (FromJSON (..))+import Data.Default (Default (..))+import Data.List (lookup)+import Effectful (Effect, IOE)+import Effectful.Dispatch.Dynamic (localSeqUnlift, reinterpret, reinterpretWith)+import Effectful.Reader.Static (Reader, ask, local, runReader)+import Effectful.TH (makeEffect)+import Effectful.Writer.Static.Shared (Writer, tell)+import System.IO (Handle, hFlush, stdout)++import Data.ByteString.Char8 qualified as B8++import Atelier.Effects.Env (Env, getEnvironment)+import Atelier.Types.JsonReadShow (JsonReadShow (..))+import Atelier.Types.QuietSnake (QuietSnake (..))+++-- | Effect for structured logging with hierarchical namespaces.+data Log :: Effect where+    -- | Emit a fully-formed log 'Message'.+    LogMsg :: Message -> Log m ()+    -- | Run an action with an extra namespace segment appended to the current+    -- one.+    WithNamespace :: Namespace -> m a -> Log m a+    -- | Get the namespace in effect for the current action.+    GetNamespace :: Log m Namespace+++-- | A single log record.+data Message = Message+    { namespace :: Namespace+    -- ^ The hierarchical namespace the message was logged under.+    , text :: Text+    -- ^ The human-readable message body.+    , severity :: Severity+    -- ^ The severity level of the message.+    , stack :: CallStack+    -- ^ The call site, captured via 'HasCallStack'.+    }+++newtype Namespace = Namespace Text+    deriving stock (Eq, Show)+    deriving newtype (IsString)+++instance Semigroup Namespace where+    Namespace "" <> Namespace b = Namespace b+    Namespace a <> Namespace "" = Namespace a+    Namespace a <> Namespace b = Namespace (a <> "." <> b)+++-- | Logging configuration.+data Config = Config+    { minimumSeverity :: Severity+    -- ^ Messages below this severity are discarded.+    }+    deriving stock (Eq, Generic, Show)+    deriving (FromJSON) via QuietSnake Config+++-- | Log severity levels, ordered from least to most severe.+data Severity+    = -- | Verbose diagnostic detail.+      DEBUG+    | -- | Normal operational information.+      INFO+    | -- | Something unexpected, but recoverable.+      WARN+    | -- | A failure that needs attention.+      ERROR+    deriving stock (Bounded, Enum, Eq, Ord, Read, Show)+    deriving (FromJSON) via (JsonReadShow Severity)+++instance Default Config where+    def =+        Config+            { minimumSeverity = minBound+            }+++makeEffect ''Log+++-- | Log a message at the given severity, capturing the current namespace and+-- call site.+log :: (HasCallStack, Log :> es) => Severity -> Text -> Eff es ()+log severity text = do+    namespace <- getNamespace+    withFrozenCallStack+        $ logMsg+            Message+                { stack = callStack+                , namespace+                , severity+                , text+                }+++-- | Log a message at 'DEBUG' severity.+debug :: (HasCallStack, Log :> es) => Text -> Eff es ()+debug = withFrozenCallStack $ log DEBUG+++-- | Log a message at 'INFO' severity.+info :: (HasCallStack, Log :> es) => Text -> Eff es ()+info = withFrozenCallStack $ log INFO+++-- | Log a message at 'WARN' severity.+warn :: (HasCallStack, Log :> es) => Text -> Eff es ()+warn = withFrozenCallStack $ log WARN+++-- | Log a message at 'ERROR' severity.+err :: (HasCallStack, Log :> es) => Text -> Eff es ()+err = withFrozenCallStack $ log ERROR+++-- | Consumes `Log` effects, and discards the logged messages+runLogNoOp :: Eff (Log : es) a -> Eff es a+runLogNoOp = reinterpret (runReader (Namespace "")) $ \env -> \case+    LogMsg _ -> pure ()+    WithNamespace ns act -> localSeqUnlift env $ \unlift ->+        local (<> ns) $ unlift act+    GetNamespace -> ask+++-- | Interpret 'Log' by writing formatted messages to stdout.+--+-- The minimum severity defaults to 'Config'\'s @minimumSeverity@, but can be+-- overridden at runtime by the @DEBUG@, @LOGGING@ or @LOG@ environment+-- variables (checked in that order).+runLog :: (Env :> es, IOE :> es, Reader Config :> es) => Eff (Log : es) a -> Eff es a+runLog action = do+    config <- ask+    env <- getEnvironment+    let overrideLog = (>>= readMaybe) $ lookup "LOG" env+        overrideLogging = (>>= readMaybe) $ lookup "LOGGING" env+        overrideDebug = (>>= \x -> if x == "0" then Nothing else Just DEBUG) $ lookup "DEBUG" env+    let severity =+            fromMaybe config.minimumSeverity+                $ overrideDebug <|> overrideLogging <|> overrideLog++    reinterpretWith (runReader (Namespace "")) action \lenv -> \case+        LogMsg msg ->+            liftIO $ when (msg.severity >= severity) do+                -- NOTE: We use hPutStr here with an appended newline because+                -- hPutStrLn is not atomic for ByteStrings longer than 1024 bytes.+                -- Data.Text.IO.hPutStrLn is not atomic for even short Texts.+                B8.hPutStr stdout+                    . encodeUtf8+                    . (<> "\n")+                    . formatMessage+                    $ msg+                hFlush stdout+        WithNamespace ns act -> localSeqUnlift lenv $ \unlift ->+            local (<> ns) $ unlift act+        GetNamespace -> ask+++-- | Like 'runLog' but writes to the given 'Handle' instead of stdout.+-- Useful for daemons that want to write logs to a file.+runLogToHandle :: (IOE :> es) => Handle -> Severity -> Eff (Log : es) a -> Eff es a+runLogToHandle handle minSeverity action =+    reinterpretWith (runReader (Namespace "")) action \env -> \case+        LogMsg msg ->+            liftIO $ when (msg.severity >= minSeverity) do+                B8.hPutStr handle . encodeUtf8 . (<> "\n") . formatMessage $ msg+                hFlush handle+        WithNamespace ns act -> localSeqUnlift env $ \unlift ->+            local (<> ns) $ unlift act+        GetNamespace -> ask+++-- | Interpret 'Log' by collecting messages into a 'Writer', for tests.+runLogWriter :: (Writer [Message] :> es) => Eff (Log : es) a -> Eff es a+runLogWriter = reinterpret (runReader (Namespace "")) $ \env -> \case+    LogMsg msg -> tell [msg]+    WithNamespace ns act -> localSeqUnlift env $ \unlift ->+        local (<> ns) $ unlift act+    GetNamespace -> ask+++formatMessage :: Message -> Text+formatMessage msg =+    mconcat+        [ square $ show msg.severity+        , " "+        , showNamespace msg.namespace+        , msg.text+        ]+  where+    showNamespace (Namespace "") = ""+    showNamespace (Namespace ns) = square ns <> " "+++square :: Text -> Text+square s = "[" <> s <> "]"
+ src/Atelier/Effects/Monitoring/Metrics.hs view
@@ -0,0 +1,125 @@+-- | Metrics effect for Prometheus metrics collection.+--+-- Provides operations for tracking application metrics.+--+-- == Basic Usage+--+-- @+-- myComponent :: (Metrics :> es) => Eff es ()+-- myComponent = do+--     gaugeSet "hoard_connected_peers" 5.0+--     counterInc "hoard_blocks_received_total"+-- @+--+-- == Available Metric Types+--+-- * Gauges: Point-in-time values that can go up or down+-- * Counters: Monotonically increasing values+-- * Histograms: Distributions with buckets for measuring durations+module Atelier.Effects.Monitoring.Metrics+    ( -- * Effect+      Metrics++      -- * Gauge Operations+    , gaugeSet+    , gaugeInc+    , gaugeDec++      -- * Counter Operations+    , counterInc+    , counterAdd++      -- * Histogram Operations+    , histogramObserve+    , withHistogramTiming++      -- * Export Operations+    , exportMetrics++      -- * Interpreters+    , runMetrics+    , runMetricsNoOp+    ) where++import Data.Time.Clock (diffUTCTime)+import Effectful (Effect, IOE)+import Effectful.Dispatch.Dynamic (interpret, interpretWith, localSeqUnlift)+import Effectful.TH (makeEffect)++import Prometheus qualified as Prom+import Prometheus.Metric.GHC qualified as GHC++import Atelier.Effects.Clock (Clock, currentTime)+import Atelier.Effects.Monitoring.Tracing (Tracing, withSpan)++import Atelier.Effects.Monitoring.Metrics.Registry qualified as Registry+++-- | Metrics effect for tracking application metrics+data Metrics :: Effect where+    -- | Set a named gauge to a specific value.+    GaugeSet :: Text -> Double -> Metrics m ()+    -- | Increment a named gauge by 1.+    GaugeInc :: Text -> Metrics m ()+    -- | Decrement a named gauge by 1.+    GaugeDec :: Text -> Metrics m ()+    -- | Increment a named counter by 1.+    CounterInc :: Text -> Metrics m ()+    -- | Add a value to a named counter.+    CounterAdd :: Text -> Double -> Metrics m ()+    -- | Observe a value in a named histogram.+    HistogramObserve :: Text -> Double -> Metrics m ()+    -- | Time an action and record its duration to a histogram metric+    WithHistogramTiming :: Text -> m a -> Metrics m a+    -- | Export all collected metrics in Prometheus text format.+    ExportMetrics :: Metrics m Text+++makeEffect ''Metrics+++-- | Run the Metrics effect with prometheus-client+--+-- Initializes the metric registry and registers GHC metrics automatically.+runMetrics+    :: forall es a+     . (Clock :> es, IOE :> es, Tracing :> es)+    => Eff (Metrics : es) a+    -> Eff es a+runMetrics action = do+    -- Initialize metrics registry and register GHC metrics++    handles <- withSpan "metrics.setup" do+        void $ liftIO $ Prom.register GHC.ghcMetrics+        liftIO Registry.initMetricHandles++    interpretWith action \env -> \case+        GaugeSet name value -> withSpan "metrics.gauge_set" $ liftIO $ Registry.setGauge handles name value+        GaugeInc name -> withSpan "metrics.gauge_inc" $ liftIO $ Registry.incGauge handles name+        GaugeDec name -> withSpan "metrics.gauge_dec" $ liftIO $ Registry.decGauge handles name+        CounterInc name -> withSpan "metrics.counter_inc" $ liftIO $ Registry.incCounter handles name+        CounterAdd name value -> withSpan "metrics.counter_add" $ liftIO $ Registry.addCounter handles name value+        HistogramObserve name value -> withSpan "metrics.histogram_observe" $ liftIO $ Registry.observeHistogram handles name value+        WithHistogramTiming metricName eff -> do+            start <- currentTime+            result <- localSeqUnlift env \unlift -> unlift eff+            end <- currentTime+            let duration = realToFrac $ diffUTCTime end start+            withSpan "metrics.with_histogram_timing.histogram_observe"+                $ liftIO+                $ Registry.observeHistogram handles metricName duration+            pure result+        ExportMetrics -> withSpan "metrics.export_metrics" $ liftIO $ decodeUtf8 <$> Prom.exportMetricsAsText+++-- | No-op interpreter that discards all metrics operations+runMetricsNoOp :: Eff (Metrics : es) a -> Eff es a+runMetricsNoOp = interpret \env -> \case+    GaugeSet _ _ -> pure ()+    GaugeInc _ -> pure ()+    GaugeDec _ -> pure ()+    CounterInc _ -> pure ()+    CounterAdd _ _ -> pure ()+    HistogramObserve _ _ -> pure ()+    WithHistogramTiming _ eff -> localSeqUnlift env \unlift -> unlift eff+    ExportMetrics -> pure ""
+ src/Atelier/Effects/Monitoring/Metrics/Registry.hs view
@@ -0,0 +1,119 @@+-- | Metric registry for managing Prometheus metrics.+--+-- The actual implementation of the `runMetrics` handler.+module Atelier.Effects.Monitoring.Metrics.Registry+    ( MetricHandles+    , initMetricHandles+    , setGauge+    , incGauge+    , decGauge+    , incCounter+    , addCounter+    , observeHistogram+    ) where++import Data.IORef (IORef, atomicModifyIORef', newIORef, readIORef)++import Data.Map.Strict qualified as Map+import Prometheus qualified as Prom+++-- | Mutable handles to the registered Prometheus metrics, keyed by name and+-- created on first use.+data MetricHandles = MetricHandles+    { gauges :: IORef (Map Text Prom.Gauge)+    , counters :: IORef (Map Text Prom.Counter)+    , histograms :: IORef (Map Text Prom.Histogram)+    }+++-- | Initialize empty metric handles+initMetricHandles :: IO MetricHandles+initMetricHandles = do+    MetricHandles+        <$> newIORef mempty+        <*> newIORef mempty+        <*> newIORef mempty+++-- | Set a gauge to a specific value+setGauge :: MetricHandles -> Text -> Double -> IO ()+setGauge handles name value = do+    g <- getOrCreateGauge handles name+    Prom.setGauge g value+++-- | Increment a gauge by 1+incGauge :: MetricHandles -> Text -> IO ()+incGauge handles name = do+    g <- getOrCreateGauge handles name+    Prom.incGauge g+++-- | Decrement a gauge by 1+decGauge :: MetricHandles -> Text -> IO ()+decGauge handles name = do+    g <- getOrCreateGauge handles name+    Prom.decGauge g+++-- | Increment a counter by 1+incCounter :: MetricHandles -> Text -> IO ()+incCounter handles name = do+    c <- getOrCreateCounter handles name+    Prom.incCounter c+++-- | Add a value to a counter+addCounter :: MetricHandles -> Text -> Double -> IO ()+addCounter handles name value = do+    c <- getOrCreateCounter handles name+    void $ Prom.addCounter c value+++-- | Observe a value in a histogram+observeHistogram :: MetricHandles -> Text -> Double -> IO ()+observeHistogram handles name value = do+    h <- getOrCreateHistogram handles name+    Prom.observe h value+++-- | Get or create a gauge metric+getOrCreateGauge :: MetricHandles -> Text -> IO Prom.Gauge+getOrCreateGauge handles name = do+    gaugeMap <- readIORef handles.gauges+    case Map.lookup name gaugeMap of+        Just g -> pure g+        Nothing -> do+            g <- Prom.register $ Prom.gauge (Prom.Info name "")+            atomicModifyIORef' handles.gauges $ \m ->+                (Map.insert name g m, ())+            pure g+++-- | Get or create a counter metric+getOrCreateCounter :: MetricHandles -> Text -> IO Prom.Counter+getOrCreateCounter handles name = do+    counterMap <- readIORef handles.counters+    case Map.lookup name counterMap of+        Just c -> pure c+        Nothing -> do+            c <- Prom.register $ Prom.counter (Prom.Info name "")+            atomicModifyIORef' handles.counters $ \m ->+                (Map.insert name c m, ())+            pure c+++-- | Get or create a histogram metric+getOrCreateHistogram :: MetricHandles -> Text -> IO Prom.Histogram+getOrCreateHistogram handles name = do+    histogramMap <- readIORef handles.histograms+    case Map.lookup name histogramMap of+        Just h -> pure h+        Nothing -> do+            -- Default buckets for duration metrics: 1ms, 10ms, 100ms, 1s, 10s+            let buckets = [0.001, 0.01, 0.1, 1.0, 10.0]+            h <- Prom.register $ Prom.histogram (Prom.Info name "") buckets+            atomicModifyIORef' handles.histograms $ \m ->+                (Map.insert name h m, ())+            pure h
+ src/Atelier/Effects/Monitoring/Metrics/Server.hs view
@@ -0,0 +1,50 @@+-- | Effect for running the Prometheus metrics HTTP server.+--+-- Wraps a Warp server that exposes the current metrics registry over HTTP, so+-- callers start it through the effect system rather than raw 'IO'.+module Atelier.Effects.Monitoring.Metrics.Server+    ( -- * Effect+      MetricsServer++      -- * Operations+    , runMetricsServer++      -- * Interpreters+    , runMetricsServerIO+    ) where++import Effectful (Effect, IOE)+import Effectful.Dispatch.Dynamic (interpret_)+import Effectful.TH (makeEffect)+import Network.HTTP.Types (status200)+import Network.Wai (Application, responseLBS)++import Network.Wai.Handler.Warp qualified as Warp+import Prometheus qualified as Prom+++-- | Running the Prometheus metrics HTTP server.+data MetricsServer :: Effect where+    -- | Start an HTTP server that exposes Prometheus metrics at any path on the+    -- given port. Blocks until the server stops, which normally only happens on+    -- error; intended to be run in a background thread.+    RunMetricsServer :: Int -> MetricsServer m ()+++makeEffect ''MetricsServer+++-- | Interpret 'MetricsServer' by running a real Warp HTTP server.+runMetricsServerIO :: (IOE :> es) => Eff (MetricsServer : es) a -> Eff es a+runMetricsServerIO = interpret_ \case+    RunMetricsServer port -> liftIO $ Warp.run port metricsApp+++metricsApp :: Application+metricsApp _req respond = do+    payload <- Prom.exportMetricsAsText+    respond+        $ responseLBS+            status200+            [("Content-Type", "text/plain; version=0.0.4; charset=utf-8")]+            payload
+ src/Atelier/Effects/Monitoring/Tracing.hs view
@@ -0,0 +1,293 @@+-- | Tracing effect for distributed tracing with OpenTelemetry.+--+-- Provides operations for creating spans, adding attributes, and propagating trace context.+--+-- == Basic Usage+--+-- @+-- myHandler :: (Tracing :> es) => Eff es ()+-- myHandler = do+--     withSpan "api.create_user" $ do+--         addAttribute "user.id" "123"+--         -- ... do work ...+--         setStatus Ok+-- @+module Atelier.Effects.Monitoring.Tracing+    ( -- * Effect+      Tracing (..)++      -- * Span Operations+    , withSpan+    , withSpanLinked+    , withLinkPropagation+    , addAttribute+    , addEvent+    , setStatus+    , getSpanContext+    , OT.ToAttribute (..)+    , Attr (..)+    , ToAttributeShow (..)++      -- * Interpreters+    , runTracing+    , runTracingFromConfig+    , runTracingNoOp++      -- * Configuration+    , TracingConfig (..)++      -- * Re-exports+    , SpanStatus (..)+    , SpanContext+    ) where++import Data.Aeson (FromJSON, ToJSON)+import Data.Default (Default (..))+import Effectful (Effect, IOE, Limit (..), Persistence (..), UnliftStrategy (..))+import Effectful.Dispatch.Dynamic (interposeWith, interpret, interpretWith, localSeqUnlift, localUnlift)+import Effectful.Exception (bracket, onException)+import Effectful.Reader.Static (Reader, ask)+import Effectful.TH (makeEffect)++import Data.HashMap.Strict qualified as HashMap+import OpenTelemetry.Context qualified as Context+import OpenTelemetry.Context.ThreadLocal qualified as ThreadLocal+import OpenTelemetry.Trace qualified as OT+import OpenTelemetry.Trace.Core qualified as OT++import Atelier.Effects.Timeout (Timeout, timeout)+import Atelier.Time (Second)+import Atelier.Types.QuietSnake (QuietSnake (..))+import Atelier.Types.WithDefaults (WithDefaults (..))++import Atelier.Effects.Monitoring.Tracing.Provider qualified as Provider+++-- | Tracing configuration for OpenTelemetry+data TracingConfig = TracingConfig+    { enabled :: Bool+    -- ^ Enable tracing+    , serviceName :: Text+    -- ^ Service name for traces+    , otlpEndpoint :: Text+    -- ^ OTLP endpoint (e.g., "http://localhost:4318")+    }+    deriving stock (Eq, Generic, Show)+    deriving (ToJSON) via QuietSnake TracingConfig+    deriving (FromJSON) via WithDefaults (QuietSnake TracingConfig)+++instance Default TracingConfig where+    def =+        TracingConfig+            { enabled = False+            , serviceName = "hoard"+            , otlpEndpoint = "http://localhost:4318"+            }+++-- | Span status for indicating success or failure+data SpanStatus+    = -- | The operation completed successfully.+      Ok+    | -- | The operation failed, with an explanatory message.+      Error Text+    deriving stock (Eq, Show)+++-- | Opaque span context for correlating traces with metrics+type SpanContext = OT.SpanContext+++-- | Tracing effect for distributed tracing+data Tracing :: Effect where+    -- | Execute an action within a named span (bracket-style, automatic cleanup)+    WithSpan :: Text -> m a -> Tracing m a+    -- | Execute an action within a named span with links to other span contexts+    WithSpanLinked :: Text -> [SpanContext] -> m a -> Tracing m a+    -- | Add an attribute to the current span+    AddAttribute :: (OT.ToAttribute attr) => Text -> attr -> Tracing m ()+    -- | Add an event to the current span+    AddEvent :: (OT.ToAttribute attr) => Text -> [(Text, attr)] -> Tracing m ()+    -- | Set the status of the current span+    SetStatus :: SpanStatus -> Tracing m ()+    -- | Get the current span context (for exemplars)+    GetSpanContext :: Tracing m (Maybe SpanContext)+    -- | Get the current OpenTelemetry context (internal use)+    GetCurrentContext :: Tracing m Context.Context+++-- | Useful to create a heterogeneous list of attribute values. These two are equivalent:+--+-- @+-- addEvent "foo" [OT.toAttribute 1, OT.toAttribute "foo"]+-- addEvent "foo" [Attr 1, Attr "foo"]+-- @+data Attr where+    Attr :: (OT.ToAttribute a) => a -> Attr+++instance OT.ToAttribute Attr where+    toAttribute (Attr a) = OT.toAttribute a+++-- | Wrapper that turns any 'Show'able value into an OpenTelemetry attribute via+-- its 'Show' instance. Derive an attribute instance @via 'ToAttributeShow' T@,+-- or wrap a value directly.+newtype ToAttributeShow a = ToAttributeShow+    { getToAttributeShow :: a+    }+++instance (Show a) => OT.ToPrimitiveAttribute (ToAttributeShow a) where+    toPrimitiveAttribute = OT.TextAttribute . show . getToAttributeShow+++instance (Show a) => OT.ToAttribute (ToAttributeShow a)+++makeEffect ''Tracing+++-- | Run an action with automatic span link propagation for fire-and-forget forks.+--+-- Any span created with no current parent (i.e., a root span) will automatically+-- receive a link to @parentCtx@. Nested spans inside those are unaffected — they+-- already have a parent and follow normal child semantics.+--+-- This avoids the trace growth problem caused by parent-child propagation in+-- long-running loops: each loop iteration's work becomes its own trace, linked+-- back to the originating span rather than piling spans onto a single trace.+withLinkPropagation :: (Tracing :> es) => Maybe SpanContext -> Eff es a -> Eff es a+withLinkPropagation Nothing action = action+withLinkPropagation (Just parentSpanCtx) action =+    interposeWith action $ \env -> \case+        WithSpan name m -> do+            currentCtx <- getCurrentContext+            localUnlift env (ConcUnlift Persistent Unlimited) $ \unlift ->+                case Context.lookupSpan currentCtx of+                    Nothing -> withSpanLinked name [parentSpanCtx] (unlift m)+                    Just _ -> withSpan name (unlift m)+        WithSpanLinked name ctxs m ->+            localUnlift env (ConcUnlift Persistent Unlimited) $ \unlift ->+                withSpanLinked name ctxs (unlift m)+        AddAttribute key val -> addAttribute key val+        AddEvent name attrs -> addEvent name attrs+        SetStatus status -> setStatus status+        GetSpanContext -> getSpanContext+        GetCurrentContext -> getCurrentContext+++-- | Run the Tracing effect with OpenTelemetry+--+-- Initializes the tracer provider and manages span lifecycle.+runTracing+    :: (IOE :> es, Timeout :> es)+    => Bool+    -- ^ Tracing enabled flag+    -> Text+    -- ^ Service name+    -> Text+    -- ^ OTLP endpoint+    -> Eff (Tracing : es) a+    -> Eff es a+runTracing enabled serviceName otlpEndpoint action+    | not enabled = runTracingNoOp action+    | otherwise =+        bracket+            (liftIO $ Provider.initTracingState serviceName otlpEndpoint)+            (\tracingState -> void $ timeout (3 :: Second) $ liftIO $ Provider.shutdownTracingState tracingState)+            $ \tracingState -> interpretWith action $ \env -> \case+                WithSpan spanName innerAction -> localSeqUnlift env $ \unlift -> do+                    currentCtx <- liftIO ThreadLocal.getContext+                    newSpan <- liftIO $ OT.createSpan tracingState.tracer currentCtx spanName OT.defaultSpanArguments+                    let newCtx = Context.insertSpan newSpan currentCtx+                    oldCtx <- liftIO $ ThreadLocal.attachContext newCtx+                    innerResult <-+                        unlift innerAction `onException` do+                            liftIO $ OT.setStatus newSpan (OT.Error "Exception occurred")+                    -- Restore the old context+                    liftIO $ void $ case oldCtx of+                        Just ctx -> ThreadLocal.attachContext ctx+                        Nothing -> ThreadLocal.detachContext+                    liftIO $ OT.endSpan newSpan Nothing+                    pure innerResult+                WithSpanLinked spanName linkedContexts innerAction -> localSeqUnlift env $ \unlift -> do+                    currentCtx <- liftIO ThreadLocal.getContext+                    let spanArgs =+                            OT.defaultSpanArguments+                                { OT.links = map (\ctx -> OT.NewLink ctx mempty) linkedContexts+                                }+                    newSpan <- liftIO $ OT.createSpan tracingState.tracer currentCtx spanName spanArgs+                    let newCtx = Context.insertSpan newSpan currentCtx+                    oldCtx <- liftIO $ ThreadLocal.attachContext newCtx+                    innerResult <-+                        unlift innerAction `onException` do+                            liftIO $ OT.setStatus newSpan (OT.Error "Exception occurred")++                    -- Restore the old context+                    liftIO $ void $ case oldCtx of+                        Just ctx -> ThreadLocal.attachContext ctx+                        Nothing -> ThreadLocal.detachContext+                    liftIO $ OT.endSpan newSpan Nothing+                    pure innerResult+                AddAttribute key value -> do+                    currentCtx <- liftIO ThreadLocal.getContext+                    case Context.lookupSpan currentCtx of+                        Just currentSpan ->+                            liftIO $ OT.addAttribute currentSpan key (OT.toAttribute value)+                        Nothing ->+                            -- No active span, ignore+                            pure ()+                AddEvent eventName attributes -> do+                    currentCtx <- liftIO ThreadLocal.getContext+                    case Context.lookupSpan currentCtx of+                        Just currentSpan -> do+                            let attrMap = HashMap.fromList $ map (\(k, v) -> (k, OT.toAttribute v)) attributes+                            let event = OT.NewEvent eventName attrMap Nothing+                            liftIO $ OT.addEvent currentSpan event+                        Nothing ->+                            -- No active span, ignore+                            pure ()+                SetStatus status -> do+                    currentCtx <- liftIO ThreadLocal.getContext+                    case Context.lookupSpan currentCtx of+                        Just currentSpan ->+                            liftIO $ case status of+                                Ok -> OT.setStatus currentSpan OT.Ok+                                Error msg -> OT.setStatus currentSpan (OT.Error msg)+                        Nothing ->+                            -- No active span, ignore+                            pure ()+                GetSpanContext -> do+                    currentCtx <- liftIO ThreadLocal.getContext+                    case Context.lookupSpan currentCtx of+                        Just currentSpan -> do+                            spanCtx <- liftIO $ OT.getSpanContext currentSpan+                            pure $ Just spanCtx+                        Nothing -> pure Nothing+                GetCurrentContext -> liftIO ThreadLocal.getContext+++-- | Run the Tracing effect with config from Reader+--+-- Convenience wrapper that reads TracingConfig from the Reader effect.+runTracingFromConfig+    :: (IOE :> es, Reader TracingConfig :> es, Timeout :> es)+    => Eff (Tracing : es) a+    -> Eff es a+runTracingFromConfig action = do+    TracingConfig {enabled, serviceName, otlpEndpoint} <- ask+    runTracing enabled serviceName otlpEndpoint action+++-- | No-op interpreter that discards all tracing operations+runTracingNoOp :: Eff (Tracing : es) a -> Eff es a+runTracingNoOp = interpret $ \env -> \case+    WithSpan _ act -> localSeqUnlift env $ \unlift -> unlift act+    WithSpanLinked _ _ act -> localSeqUnlift env $ \unlift -> unlift act+    AddAttribute _ _ -> pure ()+    AddEvent _ _ -> pure ()+    SetStatus _ -> pure ()+    GetSpanContext -> pure Nothing+    GetCurrentContext -> pure Context.empty
+ src/Atelier/Effects/Monitoring/Tracing/Provider.hs view
@@ -0,0 +1,70 @@+-- | Tracing provider for managing OpenTelemetry TracerProvider and span stack.+--+-- The actual implementation backing the `runTracing` handler.+module Atelier.Effects.Monitoring.Tracing.Provider+    ( TracingState (..)+    , initTracingState+    , shutdownTracingState+    ) where++import System.Environment (setEnv)++import OpenTelemetry.Attributes qualified as OT+import OpenTelemetry.Trace qualified as OT+++-- | Handles to the initialised OpenTelemetry tracer provider and a tracer+-- derived from it.+data TracingState = TracingState+    { tracerProvider :: OT.TracerProvider+    -- ^ The global tracer provider; flushed and shut down on teardown.+    , tracer :: OT.Tracer+    -- ^ The tracer used to create spans.+    }+++-- | Initialize tracing state using global tracer provider+--+-- This uses initializeGlobalTracerProvider which reads configuration from+-- environment variables (OTEL_SERVICE_NAME, OTEL_EXPORTER_OTLP_ENDPOINT)+-- and properly sets up ID generation.+initTracingState+    :: Text+    -- ^ Service name+    -> Text+    -- ^ OTLP endpoint (e.g., "http://localhost:4318")+    -> IO TracingState+initTracingState serviceName otlpEndpoint = do+    -- Set environment variables for OpenTelemetry SDK+    setEnv "OTEL_SERVICE_NAME" (toString serviceName)+    setEnv "OTEL_EXPORTER_OTLP_ENDPOINT" (toString otlpEndpoint)++    -- Initialize the global tracer provider+    -- This reads from environment variables and sets up proper ID generation+    provider <- OT.initializeGlobalTracerProvider++    -- Create instrumentation library+    let instrumentationLibrary =+            OT.InstrumentationLibrary+                serviceName -- Library name+                "" -- Version (empty for now)+                "" -- Schema URL (empty for now)+                OT.emptyAttributes -- Attributes++    -- Get a tracer from the provider+    let tracerInstance = OT.makeTracer provider instrumentationLibrary OT.tracerOptions++    pure+        TracingState+            { tracerProvider = provider+            , tracer = tracerInstance+            }+++-- | Shutdown tracing state gracefully+--+-- Flushes any remaining spans and cleans up resources.+shutdownTracingState :: TracingState -> IO ()+shutdownTracingState tracingState = do+    -- Force shutdown of the tracer provider to flush spans+    OT.shutdownTracerProvider tracingState.tracerProvider
+ src/Atelier/Effects/Posix/Daemons.hs view
@@ -0,0 +1,53 @@+-- | An effect for managing detached daemon processes via PID files.+--+-- 'daemonize' forks a program into the background, 'isRunning' checks a daemon's+-- PID file, and 'forceKillAndWait' terminates one. Backed by the @daemons@+-- package.+module Atelier.Effects.Posix.Daemons+    ( Daemons+    , PidFile (..)+    , daemonize+    , isRunning+    , forceKillAndWait+    , runDaemons+    ) where++import Data.Default (def)+import Effectful (Effect, IOE, Limit (..), Persistence (..), UnliftStrategy (..))+import Effectful.Dispatch.Dynamic (interpretWith, localUnliftIO)+import Effectful.Exception (trySync)+import Effectful.TH (makeEffect)++import System.Posix.Daemon qualified as Daemons+++-- | Effect for managing detached daemon processes.+data Daemons :: Effect where+    -- | Daemonize the given program, ensuring it is cleanly separated from the+    -- spawning process.+    Daemonize :: PidFile -> m () -> Daemons m ()+    -- | Check whether a daemon is running for the provided PID file.+    IsRunning :: PidFile -> Daemons m Bool+    -- | Kill the daemon associated with the provided PID file using `SIGKILL`.+    ForceKillAndWait :: PidFile -> Daemons m (Either SomeException ())+++-- | The path to a daemon's PID file, used to track and control it.+newtype PidFile = PidFile {getPidFile :: FilePath}+++makeEffect ''Daemons+++-- | Interpret 'Daemons' using the @daemons@ package.+runDaemons :: (IOE :> es) => Eff (Daemons : es) a -> Eff es a+runDaemons act = do+    interpretWith act \env -> \case+        Daemonize (PidFile pidFile) program ->+            localUnliftIO env (ConcUnlift Persistent Unlimited) \unlift -> do+                Daemons.runDetached (Just pidFile) def+                    $ unlift program+        IsRunning (PidFile pidFile) ->+            liftIO $ Daemons.isRunning pidFile+        ForceKillAndWait (PidFile pidFile) ->+            trySync $ liftIO $ Daemons.brutalKill pidFile
+ src/Atelier/Effects/Posix/IO.hs view
@@ -0,0 +1,69 @@+-- |+--+-- GHC's 'System.IO.openFile' and 'System.IO.withFile' participate in an+-- advisory file-locking protocol built on @flock(2)@:+--+--   * Write\/append mode acquires an exclusive lock (@LOCK_EX@).+--   * Read mode acquires a shared lock (@LOCK_SH@).+--+-- Because these locks are advisory, processes that do not call @flock@ can+-- always read or write the file freely. GHC's own runtime, however, refuses+-- to open a file for reading while another GHC process holds an exclusive+-- lock on it — even if the underlying read would be perfectly safe - and+-- throws @resource busy (file is locked)@.+--+-- This is a problem when a long-lived daemon holds a file open in append mode+-- and a short-lived client process wants to read that file. Using 'readFdAll',+-- the client opens the file via @open(2)@ without ever calling @flock@,+-- matching the behaviour of standard Unix tools like @cat@ and @tail@.+module Atelier.Effects.Posix.IO+    ( readFdAll+    , readFdFrom+    ) where++import Foreign.Marshal.Alloc (allocaBytes)+import Foreign.Ptr (castPtr)+import System.IO (SeekMode (..))+import System.Posix.Types (Fd, FileOffset)++import Data.ByteString qualified as BS+import Data.ByteString.Builder qualified as Builder+import Data.ByteString.Lazy qualified as LBS+import System.Posix.IO qualified as Posix+++-- | Read the entire contents of a file descriptor into a lazy 'LBS.ByteString'+-- without acquiring any file lock.+--+-- The file is read in chunks via @read(2)@ (@'Posix.fdReadBuf'@) until EOF.+-- The caller retains ownership of the 'Fd' and is responsible for closing it;+-- this function does not close the descriptor after reading.+--+-- Typical use via 'Control.Exception.bracket':+--+-- @+-- result <- bracket+--     (Posix.openFd path Posix.ReadOnly Posix.defaultFileFlags)+--     Posix.closeFd+--     readFdAll+-- @+readFdAll :: Fd -> IO LBS.ByteString+readFdAll fd = Builder.toLazyByteString <$> go mempty+  where+    chunkSize = 65536 :: Int+    go acc = do+        chunk <- allocaBytes chunkSize \ptr -> do+            n <- Posix.fdReadBuf fd (castPtr ptr) (fromIntegral chunkSize)+            BS.packCStringLen (castPtr ptr, fromIntegral n)+        if BS.null chunk then+            return acc+        else+            go (acc <> Builder.byteString chunk)+++-- | Seek to @offset@ and read the remainder of a file descriptor into a lazy+-- 'LBS.ByteString' without acquiring any file lock.+readFdFrom :: FileOffset -> Fd -> IO LBS.ByteString+readFdFrom offset fd = do+    _ <- Posix.fdSeek fd AbsoluteSeek offset+    readFdAll fd
+ src/Atelier/Effects/Process.hs view
@@ -0,0 +1,104 @@+-- | Effect for spawning and interacting with external processes.+--+-- Unifies @typed-process@ (configuration, lifecycle and stream capture) and+-- the one operation only @process@ provides (process-group interruption)+-- behind a single effect, so callers never depend on either package directly.+--+-- Build a 'ProcessConfig' with the re-exported @typed-process@ DSL+-- ('proc', 'shell', 'setStdin', …), then run it with one of the operations+-- below.+module Atelier.Effects.Process+    ( -- * Effect+      Process++      -- * Building process configs (re-exported from @typed-process@)+    , ProcessConfig+    , RunningProcess+    , proc+    , shell+    , setStdin+    , setStdout+    , setStderr+    , setWorkingDir+    , setCreateGroup+    , createPipe+    , getStdin+    , getStdout+    , getStderr++      -- * Operations+    , readProcessStdout+    , readProcessSafe+    , startProcess+    , stopProcess+    , waitExitCode+    , interruptProcessGroup++      -- * Interpreters+    , runProcessIO+    ) where++import Effectful (Effect, IOE)+import Effectful.Dispatch.Dynamic (interpret_)+import Effectful.Exception (trySync)+import Effectful.TH (makeEffect)+import System.Exit (ExitCode (..))+import System.Process (interruptProcessGroupOf)+import System.Process.Typed+    ( ProcessConfig+    , createPipe+    , getStderr+    , getStdin+    , getStdout+    , proc+    , setCreateGroup+    , setStderr+    , setStdin+    , setStdout+    , setWorkingDir+    , shell+    )++import System.Process.Typed qualified as TP+++-- | @typed-process@'s started-process type, re-exported under a non-clashing+-- name (the effect itself is called 'Process'). Parameterised by its stdin,+-- stdout and stderr stream types.+type RunningProcess = TP.Process+++data Process :: Effect where+    -- | Run a process to completion, returning its exit code and captured stdout.+    ReadProcessStdout :: ProcessConfig i o e -> Process m (ExitCode, LByteString)+    -- | Spawn a process and return its handle for further interaction.+    StartProcess :: ProcessConfig i o e -> Process m (TP.Process i o e)+    -- | Stop a process: close its streams, terminate it, and wait for it to exit.+    StopProcess :: TP.Process i o e -> Process m ()+    -- | Block until the process exits and return its exit code.+    WaitExitCode :: TP.Process i o e -> Process m ExitCode+    -- | Send an interrupt (SIGINT) to the process's group. Requires the process+    -- to have been started with @'setCreateGroup' True@.+    InterruptProcessGroup :: TP.Process i o e -> Process m ()+++makeEffect ''Process+++-- | Run @cmd@ with @args@ and return its stdout as 'Text', or 'Nothing' on any+-- error (non-zero exit, the executable not being found, etc.).+readProcessSafe :: (Process :> es) => FilePath -> [String] -> Eff es (Maybe Text)+readProcessSafe cmd args = do+    result <- trySync $ readProcessStdout (proc cmd args)+    pure $ case result of+        Right (ExitSuccess, out) -> Just (decodeUtf8 out)+        _ -> Nothing+++runProcessIO :: (IOE :> es) => Eff (Process : es) a -> Eff es a+runProcessIO = interpret_ \case+    ReadProcessStdout cfg -> liftIO $ TP.readProcessStdout cfg+    StartProcess cfg -> liftIO $ TP.startProcess cfg+    StopProcess p -> liftIO $ TP.stopProcess p+    WaitExitCode p -> liftIO $ TP.waitExitCode p+    InterruptProcessGroup p -> liftIO $ interruptProcessGroupOf (TP.unsafeProcessHandle p)
+ src/Atelier/Effects/Publishing.hs view
@@ -0,0 +1,185 @@+-- | A typed publish/subscribe effect pair.+--+-- 'Pub' publishes events of a given type; 'Sub' subscribes and delivers each+-- published event to a listener. 'runPubSub' wires the two together over an+-- internal broadcast channel, propagating tracing context from publisher to+-- listener; 'runPubWriter' instead records published events to a 'Writer', for+-- tests.+--+-- Subscriptions are established asynchronously, so a listener you intend to+-- publish to should be started with 'forkListener' or 'forkListener_', which+-- block until the subscription is live and therefore cannot miss early events.+module Atelier.Effects.Publishing+    ( Pub+    , Sub+    , listen+    , listen_+    , listenWith+    , listenWith_+    , listenOnce+    , listenOnce_+    , forkListener+    , forkListener_+    , publish+    , runPubSub+    , runPubWriter+    )+where++import Data.Time (UTCTime)+import Effectful (Effect)+import Effectful.Concurrent.STM+    ( Concurrent+    , atomically+    , newEmptyTMVar+    , putTMVar+    , takeTMVar+    )+import Effectful.Dispatch.Dynamic (interpretWith, interpretWith_, interpret_, localSeqUnlift)+import Effectful.Error.Static (runErrorNoCallStack, throwError)+import Effectful.TH (makeEffect)+import Effectful.Writer.Static.Shared (Writer, tell)++import Text.Show qualified as S++import Atelier.Effects.Chan (Chan)+import Atelier.Effects.Clock (Clock)+import Atelier.Effects.Conc (Conc, fork_)+import Atelier.Effects.Monitoring.Tracing (SpanContext, Tracing)++import Atelier.Effects.Chan qualified as Chan+import Atelier.Effects.Clock qualified as Clock+import Atelier.Effects.Monitoring.Tracing qualified as Tracing+++-- | 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 ()+++-- | 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 () -> (UTCTime -> event -> m ()) -> Sub event m Void+++makeEffect ''Pub+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+++-- | 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"+++-- | Internal wrapper for events with trace context+data TracedEvent event = TracedEvent+    { event :: event+    , timestamp :: UTCTime+    , publisherSpanContext :: Maybe SpanContext+    }+++-- | Runs Pub and Sub effects with an internal channel for a specific event type.+-- Automatically captures span context from the publisher and creates linked spans in listeners.+runPubSub+    :: forall event es a+     . ( Chan :> es+       , Clock :> es+       , Tracing :> es+       )+    => Eff (Pub event : Sub event : es) a -> Eff es a+runPubSub action = do+    (inChan, _) <- Chan.newChan @(TracedEvent event)++    let handlePub eff = interpretWith_ eff \case+            Publish event -> do+                timestamp <- Clock.currentTime+                -- Capture the current span context from the publisher+                publisherSpanContext <- Tracing.getSpanContext+                Chan.writeChan inChan TracedEvent {event, timestamp, publisherSpanContext}++        handleSub eff = interpretWith eff \env -> \case+            ListenWith onSubscribed listener -> localSeqUnlift env \unlift -> do+                chan <- Chan.dupChan inChan+                unlift onSubscribed+                forever do+                    TracedEvent {event, timestamp, publisherSpanContext} <- Chan.readChan chan+                    Tracing.withLinkPropagation publisherSpanContext $ unlift $ listener timestamp event++    handleSub . handlePub $ action+++-- | Handler that uses a provided Writer effect instead of actually publishing.+-- Useful for testing and inspecting what events were published.+runPubWriter :: forall event es a. (Writer [event] :> es) => Eff (Pub event : es) a -> Eff es a+runPubWriter =+    interpret_ \case+        Publish event -> tell [event]
+ src/Atelier/Effects/Tally.hs view
@@ -0,0 +1,90 @@+-- | Tally tracking effect for counting occurrences per key+--+-- Tracks the total number of occurrences per key, delegating storage and+-- eviction to a 'Cache' interpreter.+--+-- The effect is polymorphic over both the key type and the status type returned+-- by a caller-supplied classifier function. This allows callers to define their+-- own thresholds and result types rather than relying on a single hard limit.+--+-- == Basic Usage+--+-- @+-- checkDuplicate :: (Tally DuplicateKey :> es) => DuplicateKey -> Config -> Eff es ()+-- checkDuplicate key cfg =+--     withTallyCheck key classify $ \case+--         Nothing      -> pure ()+--         Just Minor   -> warnAboutPeer+--         Just Critical -> banPeer+--   where+--     classify c+--         | c > cfg.criticalThreshold = Just Critical+--         | c > cfg.warningThreshold  = Just Minor+--         | otherwise                 = Nothing+-- @+module Atelier.Effects.Tally+    ( -- * Effect+      Tally+    , withTallyCheck++      -- * Re-exports+    , module Atelier.Effects.Cache.Config++      -- * Interpreters+    , runTally+    , runTallyConst+    ) where++import Effectful (Effect)+import Effectful.Concurrent (Concurrent)+import Effectful.Dispatch.Dynamic (interpret, localSeqUnlift, reinterpret)+import Effectful.Reader.Static (Reader)+import Effectful.TH (makeEffect)++import Atelier.Effects.Cache (cacheModify, runCacheTtl)+import Atelier.Effects.Cache.Config+import Atelier.Effects.Clock (Clock)+import Atelier.Effects.Conc (Conc)+import Atelier.Effects.Delay (Delay)+import Atelier.Effects.Log (Log)+++-- | Tally tracking effect parameterized by key type+data Tally key :: Effect where+    -- | Increment the hit count for a key and run an action based on a classifier.+    --+    -- The classifier receives the new count and produces a status value of any+    -- type the caller chooses. The continuation then receives that status.+    WithTallyCheck+        :: (Hashable key, Ord key)+        => key -> (Int -> status) -> (status -> m a) -> Tally key m a+++makeEffect ''Tally+++-- | Run the Tally effect, using a TTL-evicting cache as the backing store+runTally+    :: forall key es a+     . ( Clock :> es+       , Conc :> es+       , Concurrent :> es+       , Delay :> es+       , Hashable key+       , Log :> es+       , Reader Config :> es+       )+    => Eff (Tally key : es) a+    -> Eff es a+runTally = reinterpret (runCacheTtl @key @Int) $ \env -> \case+    WithTallyCheck key classify continuation -> localSeqUnlift env $ \unlift -> do+        count <- cacheModify key (maybe 1 (+ 1))+        unlift $ continuation (classify count)+++-- | Interpret 'Tally' with a fixed count for every key, ignoring real+-- tallying. The classifier is always handed @c@, making the outcome+-- deterministic for tests.+runTallyConst :: Int -> Eff (Tally key : es) a -> Eff es a+runTallyConst c = interpret \env -> \case+    WithTallyCheck _ classify f -> localSeqUnlift env \unlift -> unlift $ f (classify c)
+ src/Atelier/Effects/Timeout.hs view
@@ -0,0 +1,52 @@+-- | An effect for bounding a computation by a wall-clock deadline.+--+-- 'timeout' runs an action, returning 'Nothing' if it does not finish within+-- the given 'TimeUnit' duration; 'timeout_' is the variant that discards the+-- result. When the deadline passes the action is cancelled with an asynchronous+-- exception.+--+-- @+-- result <- timeout (5 :: Second) fetchRemote+-- case result of+--     Just value -> use value+--     Nothing    -> logWarn \"fetch timed out\"+-- @+module Atelier.Effects.Timeout+    ( Timeout+    , timeout+    , timeout_+    , runTimeout+    ) where++import Effectful (Effect, IOE, Limit (..), Persistence (..), UnliftStrategy (..))+import Effectful.Dispatch.Dynamic (interpret, localUnliftIO)+import Effectful.TH (makeEffect)++import System.Timeout qualified as IO++import Atelier.Time (TimeUnit (..))+++-- | Effect for bounding a computation by a wall-clock deadline.+data Timeout :: Effect where+    -- | Run an action, returning 'Just' its result if it completes within the+    -- duration, or 'Nothing' if the deadline passes first.+    Timeout :: (TimeUnit t) => t -> m a -> Timeout m (Maybe a)+++makeEffect ''Timeout+++-- | Like 'timeout', but for times where you do not need the result. If you+-- need to distinguish whether the action ran to completion, or whether it+-- timed out, you should use 'timeout'.+timeout_ :: (TimeUnit t, Timeout :> es) => t -> Eff es a -> Eff es ()+timeout_ t m = const () <$> timeout t m+++-- | Interpret 'Timeout' using 'System.Timeout.timeout'.+runTimeout :: (HasCallStack, IOE :> es) => Eff (Timeout : es) a -> Eff es a+runTimeout = interpret \env -> \case+    Timeout delay action ->+        localUnliftIO env (ConcUnlift Persistent (Limited 1)) \unlift ->+            IO.timeout (fromIntegral $ toMicroseconds delay) $ unlift action
+ src/Atelier/Effects/UUID.hs view
@@ -0,0 +1,37 @@+-- | An effect for generating UUIDs.+--+-- 'runGenUUID' produces fresh random (version 4) UUIDs; 'runGenUUIDConst'+-- returns a fixed UUID every time, for deterministic tests. The 'UUID' type is+-- re-exported from @uuid@.+module Atelier.Effects.UUID+    ( GenUUID+    , UUID+    , gen+    , runGenUUID+    , runGenUUIDConst+    ) where++import Data.UUID (UUID)+import Data.UUID.V4 (nextRandom)+import Effectful (Effect, IOE)+import Effectful.Dispatch.Dynamic (interpret_)+import Effectful.TH (makeEffect)+++-- | Effect for generating UUIDs.+data GenUUID :: Effect where+    -- | Generate a UUID.+    Gen :: GenUUID m UUID+++makeEffect ''GenUUID+++-- | Interpret 'GenUUID' by generating fresh random (version 4) UUIDs.+runGenUUID :: (IOE :> es) => Eff (GenUUID : es) a -> Eff es a+runGenUUID = interpret_ \Gen -> liftIO nextRandom+++-- | Interpret 'GenUUID' so 'gen' always returns the given fixed UUID, for tests.+runGenUUIDConst :: UUID -> Eff (GenUUID : es) a -> Eff es a+runGenUUIDConst uuid = interpret_ \Gen -> pure uuid
+ src/Atelier/Effects/Yield.hs view
@@ -0,0 +1,70 @@+-- | The producing half of a 'Yield'\/'Await' coroutine pair.+--+-- A 'Yield' computation emits values one at a time, analogous to the+-- @Writer@\/@Output@ effects. The interpreters here collect the stream+-- ('yieldToList', 'withYieldToList'), drive it ('forEach'), or transform it+-- ('map', 'mapMaybe', 'filter', 'changes', 'enumerate'). The effect itself lives+-- in "Atelier.Effects.Internal.Coroutine" and is re-exported here.+module Atelier.Effects.Yield+    ( -- * Effect+      Yield++      -- * Operations+    , yield+    , inFoldable+    , yieldEvents+    , cycleToYield++      -- * Interpreters+    , forEach+    , yieldToList+    , yieldToReverseList+    , withYieldToList+    , ignoreYield+    , enumerate+    , enumerateFrom+    , map+    , mapMaybe+    , catMaybes+    , changes+    , filter+    ) where++import Effectful.Dispatch.Dynamic (impose_, interpose_)+import Effectful.State.Static.Shared (evalState, get)+import Prelude hiding (catMaybes, filter, map, mapMaybe)++import Atelier.Effects.Internal.Coroutine+    ( Yield (..)+    , catMaybes+    , cycleToYield+    , enumerate+    , enumerateFrom+    , forEach+    , ignoreYield+    , inFoldable+    , map+    , mapMaybe+    , withYieldToList+    , yield+    , yieldEvents+    , yieldToList+    , yieldToReverseList+    )+++-- | Forward only the 'yield'ed values that satisfy a predicate, dropping the+-- rest from the stream.+filter :: (a -> Bool) -> Eff (Yield a : es) r -> Eff (Yield a : es) r+filter p = interpose_ \(Yield x) ->+    when (p x) do+        yield x+++-- | Re-yield values that differ from a reference value (supplied as the first+-- argument).+changes :: forall a es r. (Eq a) => a -> Eff (Yield a : es) r -> Eff (Yield a : es) r+changes initial = impose_ (evalState initial) \(Yield x) -> do+    curr <- get+    when (curr /= x) do+        yield x
+ src/Atelier/Exception.hs view
@@ -0,0 +1,41 @@+-- | Helpers for telling synchronous exceptions apart from asynchronous ones.+--+-- Synchronous exceptions are genuine failures worth catching, logging, or+-- retrying; asynchronous ones (thread cancellation, @SIGINT@) usually signal an+-- intentional shutdown and should be allowed to propagate. The @*SyncIO@+-- helpers catch only the former and re-throw the latter.+module Atelier.Exception+    ( isGracefulShutdown+    , trySyncIO+    , catchSyncIO+    , isSyncException+    ) where++import Effectful.Exception (SomeAsyncException, isSyncException)++import Control.Exception qualified as E+++-- | Determine if an exception represents a graceful shutdown (any async exception).+--+-- Async exceptions indicate intentional cancellation (e.g., Ki's ScopeClosing,+-- or UserInterrupt from SIGINT), as opposed to real errors that warrant logging+-- or retry logic.+isGracefulShutdown :: SomeException -> Bool+isGracefulShutdown = isJust . fromException @SomeAsyncException+++-- | Like `Control.Exception.try`, but will only catch synchronous exceptions.+trySyncIO :: IO a -> IO (Either SomeException a)+trySyncIO f = withFrozenCallStack catchSyncIO (fmap Right f) (pure . Left)+++-- | Like @Control.Exception.catch@, but only synchronous exceptions reach the+-- handler; asynchronous exceptions are re-thrown unchanged.+catchSyncIO :: (HasCallStack) => IO a -> (SomeException -> IO a) -> IO a+catchSyncIO f g =+    f `E.catch` \e ->+        if isSyncException e then+            g e+        else+            E.throwIO e
+ src/Atelier/Time.hs view
@@ -0,0 +1,86 @@+{-# OPTIONS_GHC -Wno-orphans #-}++-- | Strongly-typed time units and conversions.+--+-- Re-exports the duration types from "Data.Time.Units" — so a single import+-- covers 'Microsecond', 'Millisecond', 'Second', 'Minute' and 'Hour' — and adds+-- conversion helpers plus JSON instances for those types. Each unit serialises+-- as an integer count of itself: a 'Second' as a whole number of seconds, a+-- 'Millisecond' as milliseconds, and so on.+--+-- Note: the 'FromJSON' and 'ToJSON' instances for the time-unit types are+-- orphans, defined here because neither @aeson@ nor @time-units@ provides them.+--+-- @+-- nominalDiffTime 1.5 :: Millisecond        -- 1.5s rounded to 1500ms+-- convertUnit (5 :: Minute) :: Second       -- 300+-- toMicroseconds (2 :: Second)              -- 2000000+-- @+module Atelier.Time+    ( -- * Time units+      TimeUnit+    , Microsecond+    , Millisecond+    , Second+    , Minute+    , Hour++      -- * Conversions+    , nominalDiffTime+    , fromMicroseconds+    , toMicroseconds+    , convertUnit+    ) where++import Data.Aeson (FromJSON (..), ToJSON (..))+import Data.Time (NominalDiffTime)+import Data.Time.Units (Hour, Microsecond, Millisecond, Minute, Second, TimeUnit, convertUnit, fromMicroseconds, toMicroseconds)+++-- | Convert a 'NominalDiffTime' to any 'TimeUnit', rounding to the nearest+-- whole unit (the conversion goes through microsecond precision).+nominalDiffTime :: (TimeUnit t) => NominalDiffTime -> t+nominalDiffTime = fromMicroseconds . round @Double . (* 1_000_000) . realToFrac+++-- Orphan instances for JSON deserialization of time unit types.+-- All time units in Data.Time.Units wrap Integer, so we parse as Integer.++instance FromJSON Microsecond where+    parseJSON = fmap fromInteger . parseJSON+++instance FromJSON Millisecond where+    parseJSON = fmap fromInteger . parseJSON+++instance FromJSON Second where+    parseJSON = fmap fromInteger . parseJSON+++instance FromJSON Minute where+    parseJSON = fmap fromInteger . parseJSON+++instance FromJSON Hour where+    parseJSON = fmap fromInteger . parseJSON+++instance ToJSON Microsecond where+    toJSON us = toJSON (toMicroseconds us)+++instance ToJSON Millisecond where+    toJSON ms = toJSON (toMicroseconds ms `div` 1000)+++instance ToJSON Second where+    toJSON s = toJSON (toMicroseconds s `div` 1_000_000)+++instance ToJSON Minute where+    toJSON m = toJSON (toMicroseconds m `div` 60_000_000)+++instance ToJSON Hour where+    toJSON h = toJSON (toMicroseconds h `div` 3_600_000_000)
+ src/Atelier/Types/Base64.hs view
@@ -0,0 +1,32 @@+-- | A 'ByteString' that serialises to and from JSON as a Base64-encoded string.+--+-- Use it directly as a field type, or derive the JSON instances for a+-- @ByteString@ newtype via it, to carry binary data through JSON without+-- tripping over non-UTF-8 bytes:+--+-- @+-- newtype Token = Token ByteString+--     deriving (ToJSON, FromJSON) via Base64+-- @+module Atelier.Types.Base64+    ( Base64 (..)+    ) where++import Data.Aeson (FromJSON (..), ToJSON (..), withText)++import Data.ByteString.Base64 qualified as Base64+++-- | A 'ByteString' whose JSON representation is Base64-encoded text.+newtype Base64 = Base64 {getBase64 :: ByteString}+++instance ToJSON Base64 where+    toJSON = toJSON . decodeUtf8 @Text . Base64.encode . getBase64+++instance FromJSON Base64 where+    parseJSON = withText "Base64" $ \t ->+        case Base64.decode (encodeUtf8 t) of+            Left err -> fail err+            Right b -> pure (Base64 b)
+ src/Atelier/Types/HttpApiDataReadShow.hs view
@@ -0,0 +1,32 @@+-- | Derive 'FromHttpApiData' and 'ToHttpApiData' for a type from its 'Read' and+-- 'Show' instances.+--+-- Handy for values that appear in URL path segments or query strings and whose+-- textual form is exactly their 'Show' output, such as small enums:+--+-- @+-- data Mode = Fast | Slow+--     deriving stock (Read, Show)+--     deriving (FromHttpApiData, ToHttpApiData) via (HttpApiDataReadShow Mode)+-- @+--+-- The encoding is the bare 'Show' output, so @Fast@ travels on the wire as the+-- segment @\/mode\/Fast@ or the query parameter @?mode=Slow@, and is read back+-- with 'Read'. Values whose 'Show' output contains characters that need+-- percent-encoding (spaces, @\/@, @&@) are best avoided here.+module Atelier.Types.HttpApiDataReadShow (HttpApiDataReadShow (..)) where++import Web.HttpApiData (FromHttpApiData (..), ToHttpApiData (..))+++-- | Carrier for deriving HTTP-API-data instances via 'Read' and 'Show'.+newtype HttpApiDataReadShow a+    = HttpApiDataReadShow {getHttpApiDataReadShow :: a}+++instance (Read a) => FromHttpApiData (HttpApiDataReadShow a) where+    parseUrlPiece = bimap toText HttpApiDataReadShow . readEither . toString+++instance (Show a) => ToHttpApiData (HttpApiDataReadShow a) where+    toUrlPiece = show . getHttpApiDataReadShow
+ src/Atelier/Types/JsonReadShow.hs view
@@ -0,0 +1,39 @@+-- | 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}+++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+++instance (Show a) => ToJSON (JsonReadShow a) where+    toJSON = String . show . getJsonReadShow
+ src/Atelier/Types/QuietSnake.hs view
@@ -0,0 +1,44 @@+{-# 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+    ( 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+++opts :: Options+opts = defaultOptions {fieldLabelModifier = quietSnake}
+ src/Atelier/Types/Semaphore.hs view
@@ -0,0 +1,59 @@+-- | If you need a semaphore that works in 'STM', use+-- 'Atelier.Types.Semaphore.STM'.+module Atelier.Types.Semaphore+    ( Semaphore+    , new+    , newSet+    , wait+    , signal+    , unset+    , set+    , peek+    , withSemaphore+    ) where++import Effectful.Concurrent.STM (Concurrent, atomically)++import Atelier.Types.Semaphore.STM (Semaphore, withSemaphore)++import Atelier.Types.Semaphore.STM qualified as STM+++-- | Creates a new, unset semaphore. Waiting on this semaphore immediately will+-- block.+new :: (Concurrent :> es) => Eff es Semaphore+new = atomically STM.new+++-- | Creates a new, set semaphore. Signalling on this semaphore immediately+-- will block.+newSet :: (Concurrent :> es) => Eff es Semaphore+newSet = atomically STM.newSet+++-- | Wait for a semaphore to be set. Blocks and waits for the semaphore to be+-- set if it is not already set.+wait :: (Concurrent :> es) => Semaphore -> Eff es ()+wait = atomically . STM.wait+++-- | Ensures a semaphore is unset. Returns @True@ if the semaphore was set.+unset :: (Concurrent :> es) => Semaphore -> Eff es Bool+unset = atomically . STM.unset+++-- | Set a semaphore. Blocks and waits if the semaphore is already set.+signal :: (Concurrent :> es) => Semaphore -> Eff es ()+signal = atomically . STM.signal+++-- | Ensures a semaphore is set. Returns @True@ if the semaphore was not+-- already set.+set :: (Concurrent :> es) => Semaphore -> Eff es Bool+set = atomically . STM.set+++-- | Check if a semaphore is set, without changing its state. Returns @True@ if+-- the semaphore is set, @False@ otherwise.+peek :: (Concurrent :> es) => Semaphore -> Eff es Bool+peek = atomically . STM.peek
+ src/Atelier/Types/Semaphore/STM.hs view
@@ -0,0 +1,87 @@+-- | STM variant of 'Atelier.Types.Semaphore'.+module Atelier.Types.Semaphore.STM+    ( Semaphore+    , new+    , newSet+    , wait+    , signal+    , unset+    , set+    , peek+    , withSemaphore+    ) where++import Effectful.Concurrent.STM+    ( Concurrent+    , STM+    , TMVar+    , atomically+    , isEmptyTMVar+    , newEmptyTMVar+    , newTMVar+    , putTMVar+    , takeTMVar+    , tryPutTMVar+    , tryTakeTMVar+    )+import Effectful.Exception (bracket_)+++-- | A flag for threads to either wait to be set, or signal to other processes+-- to continue. A synchronization primitive.+--+-- Using 'wait' on an unset semaphore blocks.+-- Using 'signal' on a set semaphore blocks.+-- All other operations do not block.+--+-- Using 'wait' on a semaphore makes it unset once the wait resolves.+-- Using 'signal' on a semaphore makes it set once the signal resolves.+newtype Semaphore = Semaphore (TMVar ())+++-- | Creates a new, unset semaphore. Waiting on this semaphore immediately will+-- block.+new :: STM Semaphore+new = Semaphore <$> newEmptyTMVar+++-- | Creates a new, set semaphore. Signalling on this semaphore immediately+-- will block.+newSet :: STM Semaphore+newSet = Semaphore <$> newTMVar ()+++-- | Wait for a semaphore to be set. Blocks and waits for the semaphore to be+-- set if it is not already set.+wait :: Semaphore -> STM ()+wait (Semaphore ref) = takeTMVar ref+++-- | Ensures a semaphore is unset. Returns @True@ if the semaphore was set.+unset :: Semaphore -> STM Bool+unset (Semaphore ref) = isJust <$> tryTakeTMVar ref+++-- | Set a semaphore. Blocks and waits if the semaphore is already set.+signal :: Semaphore -> STM ()+signal (Semaphore ref) = putTMVar ref ()+++-- | Ensures a semaphore is set. Returns @True@ if the semaphore was not+-- already set.+set :: Semaphore -> STM Bool+set (Semaphore ref) = tryPutTMVar ref ()+++-- | Check if a semaphore is set, without changing its state. Returns @True@ if+-- the semaphore is set, @False@ otherwise.+peek :: Semaphore -> STM Bool+peek (Semaphore ref) = not <$> isEmptyTMVar ref+++-- | Waits for exclusive access to the semaphore before running a computation,+-- ensuring it is set before starting, and that it is signalled afterwards.+-- If another thread signals or sets the semaphore in the meantime, the caller+-- will _not_ be blocked when attempting to signal the semaphore afterwards.+withSemaphore :: (Concurrent :> es) => Semaphore -> Eff es a -> Eff es a+withSemaphore ref = bracket_ (atomically $ wait ref) (atomically $ set ref)
+ src/Atelier/Types/WithDefaults.hs view
@@ -0,0 +1,39 @@+-- | Merge a type's 'Default' value into incoming JSON before parsing, so fields+-- absent from the input fall back to their defaults instead of failing.+--+-- Derive 'FromJSON' via this wrapper when partial JSON should be completed from+-- a 'Default' instance. Missing non-'Maybe' fields then take their default+-- value rather than causing a parse error:+--+-- @+-- data Config = Config { retries :: Int, verbose :: Bool }+--     deriving stock (Generic)+--     deriving (FromJSON) via (WithDefaults Config)+--+-- instance Default Config where+--     def = Config { retries = 3, verbose = False }+-- @+--+-- Parsing @{\"verbose\": true}@ then yields @Config { retries = 3, verbose = True }@.+module Atelier.Types.WithDefaults+    ( WithDefaults (..)+    ) where++import Data.Aeson (FromJSON (..), ToJSON (..), Value (..))+import Data.Default (Default (..))++import Data.Aeson.KeyMap qualified as KM+++-- | Carrier that fills missing JSON fields from a type's 'Default' instance+-- before parsing.+newtype WithDefaults a = WithDefaults {getWithDefaults :: a}+++instance (Default a, FromJSON a, ToJSON a) => FromJSON (WithDefaults a) where+    parseJSON v = WithDefaults <$> parseJSON merged+      where+        merged = mergeLeft (toJSON (def :: a)) v++        mergeLeft (Object l) (Object r) = Object $ KM.unionWith mergeLeft l r+        mergeLeft _ r = r
+ test/Driver.hs view
@@ -0,0 +1,2 @@+{-# OPTIONS_GHC -F -pgmF tasty-discover #-}+
+ test/Unit/Atelier/ConfigSpec.hs view
@@ -0,0 +1,100 @@+module Unit.Atelier.ConfigSpec (spec_Config) where++import Data.Aeson (FromJSON, ToJSON)+import Data.Default (Default (..))+import GHC.Generics (Generically (..))+import Test.Hspec (Spec, describe, it, shouldBe)++import Data.Aeson qualified as Aeson+import Data.Aeson.KeyMap qualified as KM++import Atelier.Config (LoadedConfig (..), extractNestedConfig)+import Atelier.Types.QuietSnake (QuietSnake (..))+import Atelier.Types.WithDefaults (WithDefaults (..))+++spec_Config :: Spec+spec_Config = do+    describe "extractNestedConfig" testExtractNestedConfig+++testExtractNestedConfig :: Spec+testExtractNestedConfig = do+    it "should use default value for non-object Values" do+        let actual = extractNestedConfig @"foo" $ LoadedConfig $ Aeson.String "foo"+        actual `shouldBe` Val "default"++    it "should fetch top-level property" do+        let actual =+                extractNestedConfig @"foo"+                    $ LoadedConfig+                    $ Aeson.Object+                    $ KM.singleton "foo"+                    $ Aeson.Object+                    $ KM.singleton "value"+                    $ Aeson.String "actual"+        actual `shouldBe` Val "actual"++    it "should return default for a missing key" do+        let actual =+                extractNestedConfig @"missing"+                    $ LoadedConfig+                    $ Aeson.Object KM.empty+        actual `shouldBe` Val "default"++    it "should fetch a nested property via dot notation" do+        let actual =+                extractNestedConfig @"foo.bar"+                    $ LoadedConfig+                    $ Aeson.Object+                    $ KM.singleton "foo"+                    $ Aeson.Object+                    $ KM.singleton "bar"+                    $ Aeson.Object+                    $ KM.singleton "value"+                    $ Aeson.String "nested"+        actual `shouldBe` Val "nested"++    it "should return default for a missing intermediate segment" do+        let actual =+                extractNestedConfig @"foo.bar"+                    $ LoadedConfig+                    $ Aeson.Object KM.empty+        actual `shouldBe` Val "default"++    it "should return default for a missing leaf segment" do+        let actual =+                extractNestedConfig @"foo.bar"+                    $ LoadedConfig+                    $ Aeson.Object+                    $ KM.singleton "foo"+                    $ Aeson.Object KM.empty+        actual `shouldBe` Val "default"++    it "should return default when an intermediate value is not an object" do+        let actual =+                extractNestedConfig @"foo.bar"+                    $ LoadedConfig+                    $ Aeson.Object+                    $ KM.singleton "foo"+                    $ Aeson.String "not-an-object"+        actual `shouldBe` Val "default"++    it "should return default when the leaf value fails to decode" do+        let actual =+                extractNestedConfig @"foo"+                    $ LoadedConfig+                    $ Aeson.Object+                    $ KM.singleton "foo"+                    $ Aeson.String "not-an-object"+        actual `shouldBe` Val "default"+++data Val = Val {value :: Text}+    deriving stock (Eq, Generic, Show)+    deriving (ToJSON) via Generically Val+    deriving (FromJSON) via WithDefaults (QuietSnake Val)+++instance Default Val where+    def = Val "default"
+ test/Unit/Atelier/Effects/AwaitSpec.hs view
@@ -0,0 +1,98 @@+module Unit.Atelier.Effects.AwaitSpec (spec_Await) where++import Effectful (runEff, runPureEff)+import Effectful.Concurrent (runConcurrent)+import Effectful.State.Static.Shared (evalState, state)+import Effectful.Writer.Static.Shared (runWriter, tell)+import Test.Hspec (Spec, describe, it, shouldBe)++import Effectful.Concurrent.STM qualified as STM++import Atelier.Effects.Chan (runChan)+import Atelier.Effects.Conc (runConc)++import Atelier.Effects.Await qualified as Await+import Atelier.Effects.Yield qualified as Yield+++spec_Await :: Spec+spec_Await = do+    describe "eachAwait" testEachAwait+    describe "takeAwait" testTakeAwait+    describe "awaitYield" testAwaitYield+++testEachAwait :: Spec+testEachAwait = do+    it "answers each await with the given action's result" do+        let xs =+                runPureEff+                    . evalState @Int 0+                    . Await.eachAwait (state \s -> (s, s + 1))+                    $ replicateM 4 Await.await+        xs `shouldBe` [0, 1, 2, 3]+++testTakeAwait :: Spec+testTakeAwait = do+    it "yields exactly N values from the await stream" do+        let (_, xs) =+                runPureEff+                    . evalState @Int 0+                    . Yield.yieldToList+                    . Await.eachAwait @Int (state \s -> (s, s + 1))+                    $ Await.takeAwait 3+        xs `shouldBe` [0, 1, 2]++    describe "when N is zero" $ it "yields nothing" do+        let (_, xs) =+                runPureEff+                    . Yield.yieldToList+                    . Await.eachAwait @Int (pure 7)+                    $ Await.takeAwait 0+        xs `shouldBe` []+++testAwaitYield :: Spec+testAwaitYield = do+    it "pipes yielded values into the await stream" do+        (_, result) <-+            runTest+                $ Await.awaitYield (Yield.inFoldable @Int [1, 2, 3] >> blockForever)+                $ replicateM 3 Await.await >>= tell++        result `shouldBe` [1, 2, 3]++    it "returns the result of the awaiting computation" do+        -- The yielder blocks after yielding so the awaiter reliably wins the+        -- termination race and its 'tell' is observed; otherwise the yielder can+        -- finish first and cancel the awaiter before it writes (flaky under load).+        (_, result) <-+            runTest+                $ Await.awaitYield @Int (Yield.yield 99 >> blockForever)+                $ fmap (* 2) Await.await >>= tell . one+        result `shouldBe` [198]++    describe "when the awaiter finishes before the yielder"+        $ it "terminates with the awaiter's result" do+            (result, _) <-+                runTest . runConcurrent $ do+                    Await.awaitYield @Int+                        (Yield.inFoldable [1 .. 100] >> blockForever)+                        Await.await+            result `shouldBe` 1++    describe "when the yielder finishes before the awaiter"+        $ it "terminates with the yielder's result" do+            (result :: Int, _) <-+                runTest+                    $ Await.awaitYield @Int (Yield.yield 1 >> pure 2)+                    $ Await.await >> Await.await >> pure 1+            result `shouldBe` 2+  where+    runTest = runEff . runConcurrent . runConc . runChan . runWriter+    -- Block the current (forked) computation indefinitely; used to keep a yielder+    -- alive so the awaiter wins the awaitYield termination race. The explicit+    -- signature keeps it polymorphic across the differing effect stacks below.+    blockForever :: (STM.Concurrent :> es) => Eff es a+    blockForever = STM.atomically STM.retry
+ test/Unit/Atelier/Effects/Cache/SingleflightSpec.hs view
@@ -0,0 +1,240 @@+module Unit.Atelier.Effects.Cache.SingleflightSpec (spec_Singleflight) where++import Effectful (IOE, runEff)+import Effectful.Concurrent (Concurrent, runConcurrent)+import Effectful.Exception (catch, throwIO)+import Effectful.State.Static.Shared (State, modify, runState)+import Test.Hspec (Spec, describe, it, shouldBe, shouldThrow)++import Atelier.Effects.Cache.Singleflight (Singleflight, runSingleflight, updateCache, withCache)+import Atelier.Effects.Conc (Conc, runConc)+import Atelier.Effects.Delay (Delay, runDelay)+import Atelier.Effects.Monitoring.Tracing (Tracing, runTracingNoOp)+import Atelier.Time (Millisecond)+import Atelier.Types.Semaphore (Semaphore)++import Atelier.Effects.Conc qualified as Conc+import Atelier.Effects.Delay qualified as Delay+import Atelier.Types.Semaphore qualified as Sem+++-- | Test exception type+data TestException = TestException Text+    deriving stock (Eq, Show)+    deriving anyclass (Exception)+++-- | Run a Singleflight test with execution counter+runSingleflightTest+    :: Eff [Singleflight Int Int, State Int, Delay, Tracing, Conc, Concurrent, IOE] a+    -> IO (a, Int)+runSingleflightTest action =+    runEff+        . runConcurrent+        . runConc+        . runTracingNoOp+        . runDelay+        . runState @Int 0+        . runSingleflight @Int @Int+        $ action+++-- | A computation that increments the execution counter and returns a value+compute :: (State Int :> es) => Int -> Eff es Int+compute value = do+    modify @Int (+ 1)+    pure value+++-- | A slow computation that increments the counter+slowCompute :: (Concurrent :> es, State Int :> es) => Semaphore -> Int -> Eff es Int+slowCompute sem value = do+    Sem.wait sem+    modify @Int (+ 1)+    pure value+++spec_Singleflight :: Spec+spec_Singleflight = do+    describe "Basic Behaviors" $ do+        describe "First request executes computation" $ do+            it "executes the computation on first request" $ do+                (result, execCount) <- runSingleflightTest $ do+                    withCache 1 (compute 42)+                result `shouldBe` 42+                execCount `shouldBe` 1++        describe "Cached value returned on second request" $ do+            it "returns cached value without re-executing" $ do+                (result, execCount) <- runSingleflightTest $ do+                    r1 <- withCache 1 (compute 42)+                    r2 <- withCache 1 (compute 42)+                    pure (r1, r2)+                result `shouldBe` (42, 42)+                execCount `shouldBe` 1++            it "returns cached value across multiple sequential requests" $ do+                (results, execCount) <- runSingleflightTest $ do+                    r1 <- withCache 1 (compute 42)+                    r2 <- withCache 1 (compute 42)+                    r3 <- withCache 1 (compute 42)+                    pure [r1, r2, r3]+                results `shouldBe` [42, 42, 42]+                execCount `shouldBe` 1++        describe "Concurrent requests are deduplicated" $ do+            it "executes computation once for concurrent requests" $ do+                (results, execCount) <- runSingleflightTest $ do+                    -- Launch 10 concurrent requests for the same key+                    asyncs <- replicateM 10 do+                        sem <- Sem.new+                        async <- Conc.fork $ withCache 1 (slowCompute sem 42)+                        pure (sem, async)+                    traverse_ Sem.set $ fst <$> asyncs+                    traverse Conc.await $ snd <$> asyncs+                all (== 42) results `shouldBe` True+                length results `shouldBe` 10+                execCount `shouldBe` 1++            it "all concurrent waiters receive the same result" $ do+                (results, execCount) <- runSingleflightTest $ do+                    sem <- Sem.new+                    -- Launch concurrent requests with different delays+                    a1 <- Conc.fork $ withCache 1 (slowCompute sem 99)+                    Delay.wait (1 :: Millisecond) -- Ensure first request starts+                    a2 <- Conc.fork $ withCache 1 (compute 99)+                    a3 <- Conc.fork $ withCache 1 (compute 99)+                    Sem.signal sem -- Let first request continue+                    r1 <- Conc.await a1+                    r2 <- Conc.await a2+                    r3 <- Conc.await a3+                    pure [r1, r2, r3]+                results `shouldBe` [99, 99, 99]+                execCount `shouldBe` 1++        describe "Different keys execute independently" $ do+            it "executes separate computations for different keys" $ do+                (results, execCount) <- runSingleflightTest $ do+                    r1 <- withCache 1 (compute 10)+                    r2 <- withCache 2 (compute 20)+                    r3 <- withCache 3 (compute 30)+                    pure [r1, r2, r3]+                results `shouldBe` [10, 20, 30]+                execCount `shouldBe` 3++            it "different keys can run concurrently" $ do+                (results, execCount) <- runSingleflightTest $ do+                    sem <- Sem.newSet+                    a1 <- Conc.fork $ withCache 1 (slowCompute sem 10)+                    a2 <- Conc.fork $ withCache 2 (slowCompute sem 20)+                    a3 <- Conc.fork $ withCache 3 (slowCompute sem 30)+                    replicateM_ 3 $ Sem.signal sem+                    r1 <- Conc.await a1+                    r2 <- Conc.await a2+                    r3 <- Conc.await a3+                    pure [r1, r2, r3]+                all (\r -> r `elem` [10, 20, 30]) results `shouldBe` True+                execCount `shouldBe` 3++        describe "UpdateCache pre-populates the cache" $ do+            it "returns pre-populated value without executing computation" $ do+                (result, execCount) <- runSingleflightTest $ do+                    updateCache [(1, 99)]+                    withCache 1 (compute 42)+                result `shouldBe` 99+                execCount `shouldBe` 0++            it "pre-populated values are returned by subsequent requests" $ do+                (results, execCount) <- runSingleflightTest $ do+                    updateCache [(1, 99)]+                    r1 <- withCache 1 (compute 42)+                    r2 <- withCache 1 (compute 42)+                    pure [r1, r2]+                results `shouldBe` [99, 99]+                execCount `shouldBe` 0++        describe "UpdateCache handles multiple entries" $ do+            it "correctly handles multiple key-value pairs" $ do+                (results, execCount) <- runSingleflightTest $ do+                    updateCache [(1, 10), (2, 20), (3, 30)]+                    r1 <- withCache 1 (compute 99)+                    r2 <- withCache 2 (compute 99)+                    r3 <- withCache 3 (compute 99)+                    pure [r1, r2, r3]+                results `shouldBe` [10, 20, 30]+                execCount `shouldBe` 0++        describe "All concurrent waiters receive the result" $ do+            it "broadcasts result to all waiting requests" $ do+                (results, execCount) <- runSingleflightTest $ do+                    -- Start one slow computation and many fast waiters+                    asyncs <- replicateM 20 do+                        sem <- Sem.new+                        async <- Conc.fork $ withCache 1 (slowCompute sem 777)+                        pure (sem, async)+                    traverse_ Sem.signal $ fst <$> asyncs+                    traverse Conc.await $ snd <$> asyncs+                all (== 777) results `shouldBe` True+                length results `shouldBe` 20+                execCount `shouldBe` 1++    describe "Edge Cases" $ do+        describe "Computation throws exception" $ do+            it "propagates exception to the first caller" $ do+                let action = runSingleflightTest $ do+                        withCache @Int @Int 1 (throwIO $ TestException "boom")+                action `shouldThrow` (\(TestException msg) -> msg == "boom")++            it "exception does not get cached" $ do+                (result, execCount) <- runSingleflightTest $ do+                    -- First request throws+                    _ <-+                        (withCache @Int @Int 1 (throwIO $ TestException "boom"))+                            `catch` \(_ :: TestException) -> pure 0+                    -- Second request should re-execute+                    withCache 1 (compute 42)+                result `shouldBe` 42+                execCount `shouldBe` 1++            it "propagates exception to all concurrent waiters" $ do+                let action = runSingleflightTest $ do+                        sem <- Sem.new+                        a1 <- Conc.fork $ withCache @Int @Int 1 (slowCompute sem 42 >> throwIO (TestException "concurrent-boom"))+                        Delay.wait (1 :: Millisecond)+                        a2 <- Conc.fork $ withCache @Int @Int 1 (compute 99)+                        Sem.signal sem+                        _ <- Conc.await a1+                        Conc.await a2+                action `shouldThrow` (\(TestException msg) -> msg == "concurrent-boom")++        describe "UpdateCache on in-flight computation" $ do+            it "overrides result of in-flight computation" $ do+                (result, execCount) <- runSingleflightTest $ do+                    sem <- Sem.new+                    -- Start slow computation+                    a1 <- Conc.fork $ withCache 1 (slowCompute sem 42)+                    Delay.wait (1 :: Millisecond) -- Let it start+                    -- Update cache while computation is running+                    updateCache [(1, 999)]+                    -- Both should get the updated value+                    Sem.signal sem+                    Conc.await a1+                result `shouldBe` 999+                execCount `shouldBe` 1++            it "waiting requests receive updated value" $ do+                (results, execCount) <- runSingleflightTest $ do+                    sem <- Sem.new+                    -- Start slow computation and waiters+                    a1 <- Conc.fork $ withCache 1 (slowCompute sem 42)+                    Delay.wait (1 :: Millisecond)+                    a2 <- Conc.fork $ withCache 1 (compute 42)+                    Delay.wait (1 :: Millisecond)+                    -- Update while they're all waiting/running+                    updateCache [(1, 888)]+                    Sem.signal sem+                    r1 <- Conc.await a1+                    r2 <- Conc.await a2+                    pure [r1, r2]+                all (== 888) results `shouldBe` True+                execCount `shouldBe` 1
+ test/Unit/Atelier/Effects/CacheSpec.hs view
@@ -0,0 +1,200 @@+module Unit.Atelier.Effects.CacheSpec (spec_Cache) where++import Data.Time (UTCTime (..), addUTCTime, fromGregorian)+import Data.Time.Clock (NominalDiffTime)+import Effectful (runEff)+import Effectful.Concurrent (runConcurrent)+import Effectful.Reader.Static (runReader)+import Effectful.State.Static.Shared (evalState, modify)+import Hedgehog (forAll, (===))+import Test.Hspec (Spec, describe, it, shouldBe)+import Test.Hspec.Hedgehog (hedgehog)++import Effectful.Concurrent.STM qualified as STM+import Hedgehog.Gen qualified as Gen+import Hedgehog.Range qualified as Range++import Atelier.Effects.Cache (Config (..), cacheDelete, cacheInsert, cacheLookup, cacheModify, runCacheTtlWithWait)+import Atelier.Effects.Clock (runClockState)+import Atelier.Effects.Conc (runConc)+import Atelier.Effects.Delay (runDelay)+import Atelier.Effects.Log (runLogNoOp)+++spec_Cache :: Spec+spec_Cache = do+    describe "Basic Operations" do+        it "lookup on absent key returns Nothing" do+            result <- runCacheTest $ cacheLookup 1+            result `shouldBe` Nothing++        it "lookup after insert returns Just value" do+            result <- runCacheTest do+                cacheInsert 1 42+                cacheLookup 1+            result `shouldBe` Just 42++        it "lookup after delete returns Nothing" do+            result <- runCacheTest $ do+                cacheInsert 1 42+                cacheDelete 1+                cacheLookup 1+            result `shouldBe` Nothing++        it "insert twice updates value" do+            result <- runCacheTest $ do+                cacheInsert 1 42+                cacheInsert 1 99+                cacheLookup 1+            result `shouldBe` Just 99++        it "delete on absent key is a no-op" do+            result <- runCacheTest $ do+                cacheDelete 1+                cacheLookup 1+            result `shouldBe` Nothing++    describe "Modify" do+        it "modify on absent key uses Nothing branch" do+            result <- runCacheTest $ cacheModify @Int @Int 1 (maybe 0 (+ 1))+            result `shouldBe` 0++        it "modify on present key uses Just branch" do+            result <- runCacheTest $ do+                cacheInsert 1 10+                cacheModify 1 (maybe 0 (+ 1))+            result `shouldBe` 11++        it "modify returns the new value" do+            result <- runCacheTest $ do+                _ <- cacheModify 1 (maybe 5 (+ 5))+                cacheModify 1 (maybe 5 (+ 5))+            result `shouldBe` 10++    describe "TTL Eviction" do+        it "entry is present before TTL expires" do+            result <- runBase . runCacheTestWithWait (STM.atomically STM.retry) $ do+                cacheInsert 1 42+                cacheLookup 1+            result `shouldBe` Just 42++        it "entry is evicted after cleanup thread fires past TTL" do+            result <- runBase do+                trigger <- STM.atomically STM.newEmptyTMVar+                done <- STM.atomically STM.newEmptyTMVar+                runCacheTestWithWait (cleanupBarrier done trigger) do+                    awaitReady done+                    cacheInsert 1 42+                    v1 <- cacheLookup 1+                    modify (addUTCTime (ttl + 1))+                    stepCleanup trigger done -- run one cleanup, block until it finishes+                    v2 <- cacheLookup 1+                    pure (v1, v2)+            result `shouldBe` (Just 42, Nothing)++        it "entry within TTL survives cleanup" do+            result <- runBase do+                trigger <- STM.atomically STM.newEmptyTMVar+                done <- STM.atomically STM.newEmptyTMVar+                runCacheTestWithWait (cleanupBarrier done trigger) do+                    awaitReady done+                    cacheInsert 1 42+                    modify (addUTCTime (ttl - 1))+                    stepCleanup trigger done+                    cacheLookup 1+            result `shouldBe` Just 42++        it "re-inserted entry retains original TTL window" do+            result <- runBase do+                trigger <- STM.atomically STM.newEmptyTMVar+                done <- STM.atomically STM.newEmptyTMVar+                runCacheTestWithWait (cleanupBarrier done trigger) do+                    awaitReady done+                    cacheInsert 1 42+                    v1 <- cacheLookup 1++                    -- re-insert before TTL expires: updates value but preserves createdAt = t0+                    modify (addUTCTime (ttl - 1))+                    stepCleanup trigger done+                    cacheInsert 1 99+                    v2 <- cacheLookup 1++                    -- advance clock past original TTL+                    modify (addUTCTime 2)+                    stepCleanup trigger done+                    v3 <- cacheLookup 1++                    pure (v1, v2, v3)+            -- createdAt was preserved from the first insert, so the entry is expired and evicted+            result `shouldBe` (Just 42, Just 99, Nothing)++    describe "Properties" do+        it "insert then lookup roundtrips value" $ hedgehog do+            v <- forAll $ Gen.int (Range.linear 0 1000)+            result <- liftIO $ runCacheTest $ do+                cacheInsert 1 v+                cacheLookup 1+            result === Just v++        it "distinct keys have independent values" $ hedgehog do+            m <- forAll $ Gen.int (Range.linear 1 20)+            n <- forAll $ Gen.int (Range.linear 1 20)+            (a, b) <- liftIO $ runCacheTest $ do+                cacheInsert 1 m+                cacheInsert 2 n+                va <- cacheLookup 1+                vb <- cacheLookup 2+                pure (va, vb)+            a === Just m+            b === Just n++        it "interleaved key access is independent" $ hedgehog do+            keys <- forAll $ Gen.list (Range.linear 1 50) Gen.bool+            -- count inserts per key by interleaving+            counts <- liftIO $ runCacheTest $ do+                let step True = cacheModify @Int 1 (maybe 1 (+ 1))+                    step False = cacheModify @Int 2 (maybe 1 (+ 1))+                traverse step keys+            let key1Counts = [c | (k, c) <- zip keys counts, k]+                key2Counts = [c | (k, c) <- zip keys counts, not k]+            key1Counts === [1 .. length key1Counts]+            key2Counts === [1 .. length key2Counts]++        it "concurrent inserts to different keys don't interfere" $ hedgehog do+            n <- forAll $ Gen.int (Range.linear 1 20)+            results <- liftIO $ runCacheTest $ do+                for_ [1 .. n] \i -> cacheInsert i i+                traverse (\i -> cacheLookup i) [1 .. n]+            results === map (Just . id) [1 .. n]++        it "modify is atomic under concurrency" $ hedgehog do+            n <- forAll $ Gen.int (Range.linear 1 50)+            finalVal <- liftIO $ runCacheTest $ do+                for_ [1 .. n] \_ -> cacheModify 1 (maybe 1 (+ 1))+                cacheLookup 1+            finalVal === Just n+  where+    runBase = runEff . runConcurrent+    runCacheTest = runBase . runCacheTestWithWait (STM.atomically STM.retry)+    runCacheTestWithWait wait =+        runLogNoOp+            . runConc+            . runDelay+            . evalState epoch+            . runClockState+            . runReader (Config {entryTtl = ttl, cleanupInterval = 3600})+            . runCacheTtlWithWait @Int @Int wait+    epoch = UTCTime (fromGregorian 1970 1 1) 0+    ttl = 3600 :: NominalDiffTime++    -- Deterministic control over the background cleanup thread, replacing+    -- real-time 'Delay.wait' guesses with a handshake. The thread runs its+    -- injected wait ('cleanupBarrier') once per loop: it acknowledges that the+    -- previous cycle finished (via 'done'), then blocks for the next trigger.+    -- 'stepCleanup' triggers one cycle and blocks until that cycle's eviction has+    -- completed, so look-ups afterwards observe a settled state.+    cleanupBarrier done trigger =+        STM.atomically (STM.putTMVar done ()) >> STM.atomically (STM.takeTMVar trigger)+    awaitReady done = STM.atomically (STM.takeTMVar done)+    stepCleanup trigger done =+        STM.atomically (STM.putTMVar trigger ()) >> STM.atomically (STM.takeTMVar done)
+ test/Unit/Atelier/Effects/ChanSpec.hs view
@@ -0,0 +1,85 @@+module Unit.Atelier.Effects.ChanSpec (spec_Chan) where++import Effectful (IOE, runEff)+import Effectful.Timeout (Timeout, runTimeout)+import Hedgehog (forAll, (===))+import Test.Hspec (Spec, describe, it, shouldBe)+import Test.Hspec.Hedgehog (hedgehog)++import Hedgehog.Gen qualified as Gen+import Hedgehog.Range qualified as Range++import Atelier.Effects.Chan (Chan, dupChan, newChan, readChan, readChanBatched, runChan, writeChan)+import Atelier.Time (Millisecond, Second)+++spec_Chan :: Spec+spec_Chan = do+    describe "Basic Operations" do+        it "writeChan then readChan roundtrips a value" do+            result <- runChanTest $ do+                (inChan, outChan) <- newChan+                writeChan inChan (42 :: Int)+                readChan outChan+            result `shouldBe` 42++        it "preserves FIFO order" $ hedgehog do+            xs <- forAll $ Gen.list (Range.linear 0 50) (Gen.int Range.linearBounded)+            result <- liftIO $ runChanTest $ do+                (inChan, outChan) <- newChan+                traverse_ (writeChan inChan) xs+                replicateM (length xs) (readChan outChan)+            result === xs++        it "dupChan creates an independent reader that receives the same messages" do+            result <- runChanTest $ do+                (inChan, outChan1) <- newChan+                outChan2 <- dupChan inChan+                writeChan inChan (42 :: Int)+                v1 <- readChan outChan1+                v2 <- readChan outChan2+                pure (v1, v2)+            result `shouldBe` (42, 42)++    describe "readChanBatched" do+        describe "when items fill the batch before timeout" do+            it "returns a full batch" do+                result <- runChanTest $ do+                    (inChan, outChan) <- newChan+                    traverse_ (writeChan inChan) [1, 2, 3 :: Int]+                    readChanBatched (1 :: Second) 3 outChan+                result `shouldBe` (1 :| [2, 3])++            it "caps at batchSize even when more items are available" $ hedgehog do+                batchSize <- forAll $ Gen.int (Range.linear 1 20)+                extra <- forAll $ Gen.int (Range.linear 1 10)+                let n = batchSize + extra+                result <- liftIO $ runChanTest $ do+                    (inChan, outChan) <- newChan+                    traverse_ (writeChan inChan) [1 .. n]+                    readChanBatched (1 :: Second) batchSize outChan+                length result === batchSize++        describe "when timeout fires before batch is full" do+            it "returns a singleton when only one item is in the channel" do+                result <- runChanTest $ do+                    (inChan, outChan) <- newChan+                    writeChan inChan (1 :: Int)+                    readChanBatched (1 :: Millisecond) 5 outChan+                result `shouldBe` (1 :| [])++            it "returns a partial batch" do+                result <- runChanTest $ do+                    (inChan, outChan) <- newChan+                    writeChan inChan (1 :: Int)+                    writeChan inChan 2+                    readChanBatched (1 :: Millisecond) 5 outChan+                result `shouldBe` (1 :| [2])+++--------------------------------------------------------------------------------+-- Test Helpers+--------------------------------------------------------------------------------++runChanTest :: Eff '[Chan, Timeout, IOE] a -> IO a+runChanTest = runEff . runTimeout . runChan
+ test/Unit/Atelier/Effects/Conc/TeardownStressSpec.hs view
@@ -0,0 +1,123 @@+-- | Focused stress tests for 'Conc.scoped' teardown.+--+-- The full test suite occasionally deadlocks under heavy scheduler pressure+-- (CPU oversubscription). Earlier A/B experiments ruled out the channel+-- primitive: converting the Iterator/Publishing path from unagi to STM did not+-- change the hang rate, which points at the one layer common to every victim —+-- Ki structured-concurrency teardown in the 'Conc' effect ('runConc' /+-- 'Conc.scoped' killing and awaiting forked threads at scope close).+--+-- These tests hammer that teardown in a tight loop so a low-probability+-- lost-wakeup becomes near-certain under load, isolating it from Pub/Sub,+-- Iterator, channels, and everything else. Iteration count is tunable via+-- @ATELIER_CONC_STRESS_N@ (crank it up under @yes@-load to reproduce). Each+-- test is wrapped in a 'timeout' so a real teardown hang fails loudly instead+-- of wedging the run.+module Unit.Atelier.Effects.Conc.TeardownStressSpec (spec_ConcTeardownStress) where++import Control.Concurrent (threadDelay)+import Control.Exception (evaluate)+import Effectful (IOE, runEff)+import Effectful.Concurrent (Concurrent, runConcurrent)+import Effectful.Concurrent.STM (atomically, retry)+import System.Environment (lookupEnv)+import System.Timeout (timeout)+import Test.Hspec (Spec, describe, it, runIO, shouldBe)++import Atelier.Effects.Chan (Chan, runChan)+import Atelier.Effects.Clock (Clock, runClock)+import Atelier.Effects.Conc (Conc, fork, fork_, runConc, scoped)+import Atelier.Effects.Monitoring.Tracing (Tracing, runTracingNoOp)+import Atelier.Effects.Publishing (Pub, Sub, publish, runPubSub)++import Atelier.Effects.Iterator qualified as Iter+++spec_ConcTeardownStress :: Spec+spec_ConcTeardownStress = do+    iterations <- runIO (fromMaybe defaultIterations . (>>= readMaybe) <$> lookupEnv "ATELIER_CONC_STRESS_N")+    timeoutSecs <- runIO (fromMaybe defaultTimeoutSecs . (>>= readMaybe) <$> lookupEnv "ATELIER_CONC_STRESS_TIMEOUT_S")+    runSpin <- runIO (isJust <$> lookupEnv "ATELIER_CONC_SPIN")++    publishDelayUs <- runIO (fromMaybe defaultPublishDelayUs . (>>= readMaybe) <$> lookupEnv "ATELIER_CONC_STRESS_DELAY_US")++    let testTimeoutMicros = timeoutSecs * 1_000_000++    describe "Conc.scoped teardown stress" do+        it "reaps an STM-blocked fork_ across many scopes" do+            completed <-+                timeout testTimeoutMicros+                    $ runConcTest+                    $ replicateM_ iterations+                    $ scoped (void (fork_ blockForever))+            completed `shouldBe` Just ()++        it "reaps a two-child scope (one parked, one transient) across many scopes" do+            completed <-+                timeout testTimeoutMicros+                    $ runConcTest+                    $ replicateM_ iterations+                    $ scoped do+                        _ <- fork (liftIO (threadDelay 5))+                        void (fork_ blockForever)+            completed `shouldBe` Just ()++    -- Faithful repro of the actual full-suite victim: the 'fromEvents' Iterator+    -- pattern over its real effect stack, looped. The producer's 10us delay is+    -- the ONLY thing giving the forked listener time to subscribe before the+    -- first publish; under load that race can drop early events and wedge the+    -- consumer's 'Iter.next' (it reads exactly as many as were published, so any+    -- dropped event blocks forever). Also exercises the deep-stack+    -- 'Conc.scoped' unlift/teardown that the bare tests above strip away.+    describe "fromEvents Iterator pattern stress (full stack)" do+        it "drives the producer/listener fromEvents scope across many iterations" do+            completed <-+                timeout testTimeoutMicros+                    $ runIterTest+                    $ replicateM_ iterations+                    $ Iter.fromEvents @Int \iter -> do+                        _ <- fork do+                            liftIO (threadDelay publishDelayUs)+                            traverse_ publish [1, 2, 3 :: Int]+                        _ <- replicateM 3 (Iter.next iter)+                        pure ()+            completed `shouldBe` Just ()++    -- A non-allocating fork_ is UN-KILLABLE under -O: -fomit-yields strips the+    -- loop's safe point, so the async exception Ki throws at scope close — and+    -- the one 'timeout' would throw — can never be delivered. It would wedge an+    -- optimized build permanently and burn a core. Hence opt-in, and only safe+    -- on a -O0 build (where the boxed-Int loop still allocates and stays+    -- killable). This is the discriminating probe for the omit-yields theory.+    when runSpin+        $ describe "Conc.scoped teardown of a NON-ALLOCATING fork_ (ATELIER_CONC_SPIN=1; -O0 only)" do+            it "reaps a non-allocating spin at scope exit" do+                completed <-+                    timeout testTimeoutMicros+                        $ runConcTest+                        $ scoped (void (fork_ nonAllocatingSpin))+                completed `shouldBe` Just ()+  where+    defaultIterations = 300 :: Int+    defaultTimeoutSecs = 15 :: Int+    defaultPublishDelayUs = 10 :: Int++    blockForever :: (Concurrent :> es) => Eff es Void+    blockForever = atomically retry++    -- Boxed-Int loop: allocates (killable) at -O0, worker-wraps to a+    -- non-allocating Int# loop (un-killable) at -O.+    nonAllocatingSpin :: (IOE :> es) => Eff es Void+    nonAllocatingSpin = liftIO (evaluate (spin 0))+      where+        spin :: Int -> Void+        spin !n = spin (n + 1)+++runConcTest :: Eff '[Conc, Concurrent, IOE] a -> IO a+runConcTest = runEff . runConcurrent . runConc+++-- | Mirrors 'IteratorSpec.runTest' — the full effect stack the real victim runs on.+runIterTest :: Eff '[Pub Int, Sub Int, Chan, Clock, Tracing, Conc, Concurrent, IOE] a -> IO a+runIterTest = runEff . runConcurrent . runConc . runTracingNoOp . runClock . runChan . runPubSub @Int
+ test/Unit/Atelier/Effects/Conc/TracedSpec.hs view
@@ -0,0 +1,131 @@+module Unit.Atelier.Effects.Conc.TracedSpec (spec_ConcTraced) where++import Control.Concurrent (newEmptyMVar, putMVar, takeMVar, threadDelay)+import Data.IORef+import Effectful (IOE, runEff)+import Effectful.Concurrent (runConcurrent)+import Effectful.Dispatch.Dynamic (interpret, localUnlift)+import OpenTelemetry.Common (TraceFlags (..))+import OpenTelemetry.Internal.Trace.Id (SpanId (..), TraceId (..))+import OpenTelemetry.Trace.TraceState (TraceState (..))+import Test.Hspec (Spec, describe, it, shouldReturn, shouldSatisfy)++import OpenTelemetry.Context qualified as Context+import OpenTelemetry.Context.ThreadLocal qualified as ThreadLocal+import OpenTelemetry.Trace.Core qualified as OT++import Atelier.Effects.Conc (await, concStrat, fork, fork_)+import Atelier.Effects.Conc.Traced (runConc)+import Atelier.Effects.Monitoring.Tracing (SpanContext, Tracing (..), withLinkPropagation, withSpan)+++spec_ConcTraced :: Spec+spec_ConcTraced = do+    describe "withLinkPropagation" $ do+        it "passes through when no parent context" $ do+            ops <- newIORef []+            runEff . runTracingCapture ops+                $ withLinkPropagation Nothing+                $ withSpan "foo"+                $ pure ()+            readIORef ops `shouldReturn` [PlainSpan "foo"]++        it "converts root span to linked span when parent context given" $ do+            ops <- newIORef []+            runEff . runTracingCapture ops+                $ withLinkPropagation (Just fakeSpanCtx)+                $ withSpan "foo"+                $ pure ()+            readIORef ops `shouldReturn` [LinkedSpan "foo"]++        it "does not convert nested spans (they already have a parent)" $ do+            ops <- newIORef []+            runEff . runTracingCapture ops+                $ withSpan "outer"+                $ withLinkPropagation (Just fakeSpanCtx)+                $ withSpan "inner"+                $ pure ()+            readIORef ops `shouldReturn` [PlainSpan "outer", PlainSpan "inner"]++    describe "withConcTracingLinks" $ do+        it "does not link when forking outside any span" $ do+            ops <- newIORef []+            runEff . runConcurrent . runTracingCapture ops . runConc $ do+                t <- fork $ withSpan "child" $ pure ()+                await t+            readIORef ops `shouldReturn` [PlainSpan "child"]++        it "links forked thread's root span to the parent span" $ do+            ops <- newIORef []+            runEff . runConcurrent . runTracingCapture ops . runConc $ do+                withSpan "parent" $ do+                    t <- fork $ withSpan "child" $ pure ()+                    await t+            readIORef ops `shouldReturn` [PlainSpan "parent", LinkedSpan "child"]++        it "links fork_ thread's root span to the parent span" $ do+            ops <- newIORef []+            spanRecorded <- newEmptyMVar+            runEff . runConcurrent . runTracingCapture ops . runConc $ do+                withSpan "parent" $ do+                    fork_ $ do+                        withSpan "bg" $ pure ()+                        liftIO $ putMVar spanRecorded ()+                        liftIO $ forever $ threadDelay maxBound+                    liftIO $ takeMVar spanRecorded+            readIORef ops >>= (`shouldSatisfy` elem (LinkedSpan "bg"))+++--------------------------------------------------------------------------------+-- Test Infrastructure+--------------------------------------------------------------------------------++data SpanOp+    = PlainSpan Text+    | LinkedSpan Text+    deriving stock (Eq, Show)+++-- | A fake but valid span context for testing.+fakeSpanCtx :: SpanContext+fakeSpanCtx =+    OT.SpanContext+        (TraceFlags 0x01)+        False+        (TraceId "\0\0\0\0\0\0\0\0\0\0\0\0\0\0\0\1")+        (SpanId "\0\0\0\0\0\0\0\1")+        (TraceState [])+++-- | Test interpreter that records 'PlainSpan' vs 'LinkedSpan' operations.+--+-- Uses real thread-local storage for context tracking so that forked threads+-- correctly start with an empty context (as they would in production), allowing+-- 'withLinkPropagation' to distinguish root spans from nested ones.+runTracingCapture+    :: (IOE :> es)+    => IORef [SpanOp]+    -> Eff (Tracing : es) a+    -> Eff es a+runTracingCapture log = interpret $ \env -> \case+    WithSpan name act -> do+        liftIO $ modifyIORef' log (<> [PlainSpan name])+        currentCtx <- liftIO ThreadLocal.getContext+        let newCtx = Context.insertSpan (OT.wrapSpanContext fakeSpanCtx) currentCtx+        oldCtx <- liftIO $ ThreadLocal.attachContext newCtx+        result <- localUnlift env concStrat $ \unlift -> unlift act+        liftIO $ void $ case oldCtx of+            Just ctx -> ThreadLocal.attachContext ctx+            Nothing -> ThreadLocal.detachContext+        pure result+    WithSpanLinked name _ act -> do+        liftIO $ modifyIORef' log (<> [LinkedSpan name])+        localUnlift env concStrat $ \unlift -> unlift act+    GetSpanContext -> do+        ctx <- liftIO ThreadLocal.getContext+        liftIO $ traverse OT.getSpanContext (Context.lookupSpan ctx)+    GetCurrentContext ->+        liftIO ThreadLocal.getContext+    AddAttribute _ _ -> pure ()+    AddEvent _ _ -> pure ()+    SetStatus _ -> pure ()
+ test/Unit/Atelier/Effects/ConcSpec.hs view
@@ -0,0 +1,125 @@+module Unit.Atelier.Effects.ConcSpec (spec_Conc) where++import Control.Exception (ErrorCall (..), throwIO)+import Effectful (IOE, runEff)+import Effectful.Concurrent (Concurrent, runConcurrent)+import Effectful.Concurrent.STM (atomically, modifyTVar', newTVarIO, readTVar, retry)+import Hedgehog (forAll, (===))+import Test.Hspec (Spec, anyException, context, describe, it, shouldBe, shouldSatisfy, shouldThrow)+import Test.Hspec.Hedgehog (hedgehog)++import Data.IORef qualified as IORef+import Hedgehog.Gen qualified as Gen+import Hedgehog.Range qualified as Range++import Atelier.Effects.Conc (Conc, await, awaitAll, fork, forkTry, fork_, runConc, scoped)+import Atelier.Effects.Delay (Delay, runDelay)+import Atelier.Time (Millisecond)++import Atelier.Effects.Delay qualified as Delay+++spec_Conc :: Spec+spec_Conc = do+    describe "Thread cleanup" do+        context "without scoped" do+            it "demonstrates thread lifetime" $ runTest do+                -- This test shows threads live for the duration of their scope+                counter <- newTVarIO (0 :: Int)++                -- Thread we fork here will live until the root scope (in+                -- 'runTest') exits.+                fork_ $ forever $ atomically $ modifyTVar' counter (+ 1)++                let waitFor n = atomically do+                        v <- readTVar counter+                        if v >= n then pure v else retry++                countAfter <- waitFor 1+                finalCount <- waitFor (countAfter + 1)++                liftIO $ finalCount `shouldSatisfy` (> countAfter)++        context "with scoped" do+            it "kills nested threads when scope exits" $ runTest do+                counter <- newTVarIO (0 :: Int)++                let waitFor n = atomically do+                        v <- readTVar counter+                        if v >= n then pure v else retry++                -- Create nested scope that will clean up its threads+                scoped do+                    fork_ $ forever $ atomically $ modifyTVar' counter (+ 1)+                    -- Ensure the thread has incremented at least once+                    _ <- waitFor 1+                    pure ()+                -- Inner scope exits here - thread should be KILLED++                -- Capture count after scope exit+                countAfter <- atomically $ readTVar counter++                -- Give any leaked thread a brief window to advance the counter+                Delay.wait (1 :: Millisecond)++                -- Count should NOT increase after scope exit+                finalCount <- atomically $ readTVar counter++                liftIO $ finalCount `shouldBe` countAfter++    describe "fork and await" do+        it "returns the result of the forked computation" do+            result <- runTestSimple $ do+                t <- fork $ pure (42 :: Int)+                await t+            result `shouldBe` 42++        it "executes the forked action" do+            result <- runTestSimple $ do+                ref <- liftIO $ IORef.newIORef False+                t <- fork $ liftIO $ IORef.writeIORef ref True+                await t+                liftIO $ IORef.readIORef ref+            result `shouldBe` True++    describe "awaitAll" do+        it "waits for all forked threads to complete" $ hedgehog do+            n <- forAll $ Gen.int (Range.linear 1 20)+            result <- liftIO $ runTestSimple $ do+                ref <- liftIO $ IORef.newIORef (0 :: Int)+                replicateM_ n $ fork $ liftIO $ IORef.atomicModifyIORef' ref (\x -> (x + 1, ()))+                awaitAll+                liftIO $ IORef.readIORef ref+            result === n++    describe "forkTry" do+        it "returns Right for a successful computation" do+            result <- runTestSimple $ do+                t <- forkTry @ErrorCall $ pure (42 :: Int)+                await t+            result `shouldBe` Right 42++        it "returns Left when the forked thread throws" do+            result <- runTestSimple $ do+                t <- forkTry @ErrorCall $ liftIO $ throwIO $ ErrorCall "boom"+                await t+            (result :: Either ErrorCall Int) `shouldSatisfy` isLeft++    describe "exception propagation" do+        it "uncaught exception in forked thread propagates to the scope" do+            let action = runTestSimple $ do+                    _ <- fork $ liftIO $ throwIO $ ErrorCall "boom"+                    awaitAll+            action `shouldThrow` anyException+++--------------------------------------------------------------------------------+-- Test Helpers+--------------------------------------------------------------------------------++runTest :: Eff '[Delay, Conc, Concurrent, IOE] a -> IO a+runTest = runEff . runConcurrent . runConc . runDelay+++runTestSimple :: Eff '[Conc, Concurrent, IOE] a -> IO a+runTestSimple = runEff . runConcurrent . runConc
+ test/Unit/Atelier/Effects/ConsoleSpec.hs view
@@ -0,0 +1,40 @@+module Unit.Atelier.Effects.ConsoleSpec (spec_Console) where++import Effectful (runPureEff)+import Test.Hspec (Spec, describe, it, shouldBe)++import Atelier.Effects.Console (runConsoleToList)++import Atelier.Effects.Console qualified as Console+++spec_Console :: Spec+spec_Console = do+    describe "runConsoleToList" $ do+        describe "when nothing is logged" $ it "returns an empty list" $ do+            let (_, msgs) = runPureEff $ runConsoleToList $ pure ()+            msgs `shouldBe` []++        describe "when logging once" $ it "collects a single traced message" $ do+            let (_, msgs) = runPureEff $ runConsoleToList $ Console.putStr "hello"+            msgs `shouldBe` ["hello"]++        it "collects multiple logged messages in order" $ do+            let (_, msgs) =+                    runPureEff . runConsoleToList $ do+                        Console.putStr "first"+                        Console.putStr "second"+                        Console.putStr "third"+            msgs `shouldBe` ["first", "second", "third"]++        it "returns the result alongside the traced messages" $ do+            let (result, msgs) =+                    runPureEff . runConsoleToList $ do+                        Console.putStr "side effect"+                        pure (42 :: Int)+            result `shouldBe` 42+            msgs `shouldBe` ["side effect"]++        it "traceLn appends a newline to the message" $ do+            let (_, msgs) = runPureEff $ runConsoleToList $ Console.putStrLn "line"+            msgs `shouldBe` ["line\n"]
+ test/Unit/Atelier/Effects/DebounceSpec.hs view
@@ -0,0 +1,253 @@+module Unit.Atelier.Effects.DebounceSpec (spec_Debounce) where++import Data.Dynamic (fromDynamic, toDyn)+import Effectful (runEff)+import Effectful.Concurrent (runConcurrent)+import Test.Hspec++import Data.IORef qualified as IORef+import Effectful.Concurrent.STM qualified as STM+import StmContainers.Map qualified as Map++import Atelier.Effects.Conc (runConc)+import Atelier.Effects.Debounce+    ( Entry (..)+    , debounced+    , debouncedWith+    , ensureCallback+    , ensureEntry+    , runDebounce+    )+import Atelier.Effects.Delay (runDelay)+import Atelier.Time (Millisecond)++import Atelier.Effects.Conc qualified as Conc+import Atelier.Effects.Console qualified as Console+import Atelier.Effects.Delay qualified as Delay+++spec_Debounce :: Spec+spec_Debounce = do+    describe "runDebounce" testRunDebounce+    describe "ensureEntry" testEnsureEntry+    describe "ensureCallback" testEnsureCallback+++testEnsureEntry :: Spec+testEnsureEntry = do+    describe "new key" do+        it "gets generation 0" do+            state <- runSTM Map.new+            entry <- runSTM $ mkEntry 1 42 state (+)+            entry.generation `shouldBe` 0++        it "stores value as arg" do+            state <- runSTM Map.new+            entry <- runSTM $ mkEntry 1 42 state (+)+            (entry.arg >>= fromDynamic) `shouldBe` Just @Int 42++    describe "existing key" do+        it "increments generation" do+            state <- runSTM Map.new+            _ <- runSTM $ mkEntry 1 2 state (+)+            entry <- runSTM $ mkEntry 1 3 state (+)+            entry.generation `shouldBe` 1++        it "applies merge function to old and new value" do+            state <- runSTM Map.new+            _ <- runSTM $ mkEntry 1 5 state (+)+            entry <- runSTM $ mkEntry 1 10 state (+)+            (entry.arg >>= fromDynamic) `shouldBe` Just @Int 15++    describe "multiple updates" do+        it "accumulates generation" do+            state <- runSTM Map.new+            _ <- runSTM $ mkEntry 1 1 state (+)+            _ <- runSTM $ mkEntry 1 2 state (+)+            entry <- runSTM $ mkEntry 1 3 state (+)+            entry.generation `shouldBe` 2++        it "applies merge cumulatively" do+            state <- runSTM Map.new+            _ <- runSTM $ mkEntry 1 1 state (+)+            _ <- runSTM $ mkEntry 1 2 state (+)+            entry <- runSTM $ mkEntry 1 3 state (+)+            (entry.arg >>= fromDynamic) `shouldBe` Just @Int 6++    describe "independent keys" do+        it "do not interfere with each other" do+            state <- runSTM Map.new+            entryA <- runSTM $ mkEntry 1 10 state (+)+            entryB <- runSTM $ mkEntry 2 20 state (+)+            (entryA.arg >>= fromDynamic) `shouldBe` Just @Int 10+            (entryB.arg >>= fromDynamic) `shouldBe` Just @Int 20+            entryA.generation `shouldBe` 0+            entryB.generation `shouldBe` 0+  where+    mkEntry = ensureEntry @Int @Int+    runSTM action = runEff . runConcurrent $ STM.atomically action+++testEnsureCallback :: Spec+testEnsureCallback = do+    it "fires callback when entry's generation still matches" do+        actual <- runCallbackTest do+            state <- STM.atomically Map.new+            STM.atomically $ Map.insert (entry 0) (1 :: Int) state+            ref <- liftIO $ IORef.newIORef @Int 0+            t <-+                Conc.fork+                    $ ensureCallback @Int @Int 1 state 1 0+                    $ liftIO . IORef.writeIORef ref+            Conc.await t+            liftIO $ IORef.readIORef ref+        actual `shouldBe` 10+    it "skips callback when generation has been bumped" do+        runCallbackTest do+            state <- STM.atomically Map.new+            -- A newer event has already bumped generation to 1+            STM.atomically $ Map.insert (entry 1) (1 :: Int) state+            -- This fork was scheduled for generation 0; it should skip+            ensureCallback @Int @Int 1 state 1 0 \_ ->+                liftIO $ False `shouldBe` True+    it "skips callback when entry has been removed" do+        runCallbackTest do+            state <- STM.atomically Map.new+            ensureCallback @Int @Int 1 state 1 0 \_ ->+                liftIO $ False `shouldBe` True+  where+    runCallbackTest =+        runEff+            . runConcurrent+            . Console.runConsole+            . Delay.runDelay+            . runConc+    entry generation =+        Entry+            { generation+            , arg = Just $ toDyn @Int 10+            }+++-- These specs exercise real-timer debouncing across forked threads. Rather than+-- sleeping a fixed duration and hoping the settle fired (which races scheduling+-- under load), each callback signals a 'TMVar' and the test blocks until it+-- fires. Multi-burst tests sequence by waiting for each burst's fire, so bursts+-- cannot merge regardless of timing. A short grace after the fire guards against+-- a spurious second fire.+testRunDebounce :: Spec+testRunDebounce = do+    describe "debounced" do+        describe "when invoked once" $ it "fires once" do+            n <- runTest do+                (count, fired) <- newCounter+                debounced 50 () (bump count fired)+                awaitFire fired+                Delay.wait @Millisecond 80+                readCount count+            n `shouldBe` 1++        describe "when invoked multiple times" $ it "fires once" do+            n <- runTest do+                (count, fired) <- newCounter+                debounced 50 () (bump count fired)+                debounced 50 () (bump count fired)+                debounced 50 () (bump count fired)+                awaitFire fired+                Delay.wait @Millisecond 80+                readCount count+            n `shouldBe` 1++        describe "when invoked multiple times with a delay between" $ it "fires once per burst" do+            n <- runTest do+                (count, fired) <- newCounter+                debounced 50 () (bump count fired)+                debounced 50 () (bump count fired)+                awaitFire fired -- burst 1 settled and cleared the entry+                debounced 50 () (bump count fired)+                debounced 50 () (bump count fired)+                awaitFire fired -- burst 2 is therefore independent+                readCount count+            n `shouldBe` 2++        describe "when invoked many times" $ it "should not crash" do+            n <- runTest do+                (count, fired) <- newCounter+                replicateM_ 10_000 $ debounced 50 () (bump count fired)+                awaitFire fired+                Delay.wait @Millisecond 80+                readCount count+            n `shouldBe` 1++    describe "debouncedWith" do+        describe "when invoked once" $ it "fires callback with the provided arg" do+            got <- runTest do+                result <- STM.atomically STM.newEmptyTMVar+                debouncedWith 50 (+) () (42 :: Int) (signal result)+                awaitValue result+            got `shouldBe` Just 42++        describe "when invoked multiple times rapidly" do+            it "fires once" do+                n <- runTest do+                    (count, fired) <- newCounter+                    let cb _ = bump count fired+                    debouncedWith 50 (+) () (1 :: Int) cb+                    debouncedWith 50 (+) () (2 :: Int) cb+                    debouncedWith 50 (+) () (3 :: Int) cb+                    awaitFire fired+                    Delay.wait @Millisecond 80+                    readCount count+                n `shouldBe` 1++            it "fires callback with merged arg" do+                got <- runTest do+                    result <- STM.atomically STM.newEmptyTMVar+                    let cb = signal result+                    debouncedWith 50 (+) () (1 :: Int) cb+                    debouncedWith 50 (+) () (2 :: Int) cb+                    debouncedWith 50 (+) () (3 :: Int) cb+                    awaitValue result+                got `shouldBe` Just 6++        describe "when invoked multiple times with a delay between" $ it "fires once per burst with merged arg" do+            xs <- runTest do+                fired <- STM.atomically STM.newEmptyTMVar+                ref <- STM.atomically (STM.newTVar @[Int] [])+                let cb v = STM.atomically (STM.modifyTVar' ref (<> [v]) >> void (STM.tryPutTMVar fired ()))+                debouncedWith 50 (+) () (1 :: Int) cb+                debouncedWith 50 (+) () (2 :: Int) cb+                awaitFire fired -- burst 1 fired (1+2=3); entry cleared+                debouncedWith 50 (+) () (10 :: Int) cb+                debouncedWith 50 (+) () (20 :: Int) cb+                awaitFire fired -- burst 2 fired (10+20=30)+                STM.atomically (STM.readTVar ref)+            xs `shouldBe` [3, 30]+  where+    runTest =+        runEff+            . runConcurrent+            . runConc+            . runDelay+            . runDebounce++    -- A fire counter paired with a TMVar signalling that a fire happened.+    newCounter = do+        count <- STM.atomically (STM.newTVar @Int 0)+        fired <- STM.atomically STM.newEmptyTMVar+        pure (count, fired)+    bump count fired = STM.atomically do+        STM.modifyTVar' count (+ 1)+        void $ STM.tryPutTMVar fired ()+    readCount count = STM.atomically (STM.readTVar count)+    signal result v = STM.atomically (STM.putTMVar result v)++    -- Block until a callback signals, bounded by a generous timeout so a real+    -- regression fails loudly instead of hanging forever.+    awaitFire fired =+        awaitValue fired >>= \case+            Just () -> pure ()+            Nothing -> liftIO $ expectationFailure "debounce callback did not fire within 5s"+    awaitValue tmv =+        either (const Nothing) Just+            <$> Conc.race (Delay.wait @Millisecond 5000) (STM.atomically (STM.takeTMVar tmv))
+ test/Unit/Atelier/Effects/FileSystemSpec.hs view
@@ -0,0 +1,138 @@+module Unit.Atelier.Effects.FileSystemSpec (spec_FileSystem) where++import Control.Exception (evaluate)+import Effectful (runPureEff)+import Effectful.State.Static.Shared (State, evalState)+import Test.Hspec (Spec, anyIOException, describe, it, shouldBe, shouldThrow)++import Data.ByteString.Lazy qualified as LBS+import Data.Map.Strict qualified as M++import Atelier.Effects.FileSystem+++spec_FileSystem :: Spec+spec_FileSystem = describe "runFileSystemState" testFileSystemState+++testFileSystemState :: Spec+testFileSystemState = do+    describe "readFileBs" do+        it "reads bytes of a file present in the state" do+            run (M.singleton "/a" "hello") (readFileBs "/a")+                `shouldBe` "hello"++        it "errors when the file is absent" do+            evaluate (run M.empty (readFileBs "/missing"))+                `shouldThrow` anyIOException++    describe "readFileLbs" do+        it "reads the entire file as lazy bytes" do+            run (M.singleton "/a" "hello") (readFileLbs "/a")+                `shouldBe` ("hello" :: LBS.ByteString)++        it "errors when the file is absent" do+            evaluate (run M.empty (readFileLbs "/missing"))+                `shouldThrow` anyIOException++    describe "readFileLbsFrom" do+        it "returns full content when offset is 0" do+            run (M.singleton "/a" "hello") (readFileLbsFrom "/a" 0)+                `shouldBe` ("hello" :: LBS.ByteString)++        it "skips the leading bytes up to the given offset" do+            run (M.singleton "/a" "hello") (readFileLbsFrom "/a" 2)+                `shouldBe` ("llo" :: LBS.ByteString)++        it "returns empty when offset equals the file length" do+            run (M.singleton "/a" "hello") (readFileLbsFrom "/a" 5)+                `shouldBe` ("" :: LBS.ByteString)++        it "errors when the file is absent" do+            evaluate (run M.empty (readFileLbsFrom "/missing" 0))+                `shouldThrow` anyIOException++    describe "doesFileExist" do+        it "returns True for a key present in the state" do+            run (M.singleton "/a" "") (doesFileExist "/a")+                `shouldBe` True++        it "returns False when the key is absent" do+            run M.empty (doesFileExist "/a")+                `shouldBe` False++    describe "doesPathExist" do+        it "returns True when a key with the path as a string prefix exists" do+            run (M.singleton "/dir/file" "") (doesPathExist "/dir")+                `shouldBe` True++        it "returns False when no key shares the prefix" do+            run M.empty (doesPathExist "/dir")+                `shouldBe` False++        it "returns False for an exact-match key with no children" do+            run (M.singleton "/dir" "") (doesPathExist "/dir")+                `shouldBe` False++    describe "listDirectory" do+        it "returns all keys that start with the given path" do+            let fs = M.fromList [("/dir/a", ""), ("/dir/b", ""), ("/other/c", "")]+            sort (run fs (listDirectory "/dir"))+                `shouldBe` ["/dir/a", "/dir/b"]++        it "returns empty list when no keys share the prefix" do+            run M.empty (listDirectory "/dir")+                `shouldBe` []++        it "excludes an exact-match key" do+            let fs = M.fromList [("/dir", ""), ("/dir/a", "")]+            run fs (listDirectory "/dir")+                `shouldBe` ["/dir/a"]++    describe "removeFile" do+        it "removes the file from the state" do+            let result = run (M.singleton "/a" "x") do+                    removeFile "/a"+                    doesFileExist "/a"+            result `shouldBe` False++        it "leaves other files unaffected" do+            let result = run (M.fromList [("/a", "x"), ("/b", "y")]) do+                    removeFile "/a"+                    doesFileExist "/b"+            result `shouldBe` True++        it "is a no-op when the file is absent" do+            let result = run M.empty do+                    removeFile "/missing"+                    doesFileExist "/missing"+            result `shouldBe` False++    describe "createDirectoryIfMissing" do+        it "is a no-op — does not add any entries to the state" do+            let result = run M.empty do+                    createDirectoryIfMissing True "/new/dir"+                    doesPathExist "/new/dir"+            result `shouldBe` False++    describe "canonicalizePath" do+        it "returns the path unchanged" do+            run M.empty (canonicalizePath "/some/./path")+                `shouldBe` "/some/./path"++    describe "getCurrentDirectory" do+        it "returns /" do+            run M.empty getCurrentDirectory+                `shouldBe` "/"++    describe "getXdgRuntimeDir" do+        it "returns /tmp" do+            run M.empty getXdgRuntimeDir+                `shouldBe` "/tmp"+++run+    :: Map FilePath ByteString+    -> Eff '[FileSystem, State (Map FilePath ByteString)] a+    -> a+run fs = runPureEff . evalState fs . runFileSystemState
+ test/Unit/Atelier/Effects/FileWatcherSpec.hs view
@@ -0,0 +1,170 @@+module Unit.Atelier.Effects.FileWatcherSpec (spec_FileWatcher) where++import Control.Concurrent (forkIO, killThread, newQSem, signalQSem, waitQSem)+import Data.IORef (modifyIORef, newIORef, readIORef)+import Data.List (isSuffixOf)+import Effectful (IOE, runEff)+import Effectful.Concurrent (Concurrent, runConcurrent)+import Hedgehog (Gen, PropertyT, forAll, (===))+import Test.Hspec (Spec, describe, it, shouldBe)+import Test.Hspec.Hedgehog (hedgehog)++import Hedgehog.Gen qualified as Gen+import Hedgehog.Range qualified as Range++import Atelier.Effects.FileWatcher (FileEvent (..), FileWatcher, Watch, deduplicateDirs, dir, dirWhere, matchesAny, runFileWatcherScripted, watchFilePaths)+++spec_FileWatcher :: Spec+spec_FileWatcher = do+    describe "deduplicateDirs" do+        describe "properties" do+            it "result is an antichain: no element is an ancestor of another"+                $ hedgehog propAntichain+            it "result covers all inputs: every input has an ancestor-or-equal in the result"+                $ hedgehog propCoverage+            it "is idempotent"+                $ hedgehog propIdempotent+            it "result is a subset of the input"+                $ hedgehog propSubset++        describe "edge cases" do+            it "returns empty list unchanged" do+                deduplicateDirs [] `shouldBe` []++            it "does not treat a dir as an ancestor of a similarly named dir" do+                deduplicateDirs ["/src", "/srcover"] `shouldBe` ["/src", "/srcover"]++    describe "matchesAny" do+        it "matches a file under a watched directory" do+            matchesAny [dir "/proj/src"] "/proj/src/Foo.hs"+                `shouldBe` True++        it "does not match a relative watch dir against an absolute event path" do+            -- runFileWatcherIO must canonicalize Watch paths to absolute before+            -- calling matchesAny, because fsnotify always reports absolute paths.+            matchesAny [dir "src"] "/proj/src/Foo.hs"+                `shouldBe` False++        it "applies the file predicate" do+            matchesAny [dirWhere "/proj/src" (\f -> ".hs" `isSuffixOf` f)] "/proj/src/Foo.hs"+                `shouldBe` True+            matchesAny [dirWhere "/proj/src" (\f -> ".hs" `isSuffixOf` f)] "/proj/src/Foo.js"+                `shouldBe` False++    describe "runFileWatcherScripted" testScripted+++--------------------------------------------------------------------------------+-- Scripted interpreter tests+--------------------------------------------------------------------------------++testScripted :: Spec+testScripted = do+    describe "watchFilePaths" do+        it "calls the callback with the scripted path" do+            paths <- collectPaths ["/src/Foo.hs"]+            paths `shouldBe` ["/src/Foo.hs"]++        it "calls the callback with each path in order" do+            paths <- collectPaths ["/src/Foo.hs", "/src/Bar.hs"]+            paths `shouldBe` ["/src/Foo.hs", "/src/Bar.hs"]++        it "ignores the watch specification" do+            paths <- collectPathsWith [dir "/any"] ["/src/Foo.hs"]+            paths `shouldBe` ["/src/Foo.hs"]++        it "passes the full path to the callback unchanged" do+            let path = "/home/user/project/src/Some/Deep/Module.hs"+            paths <- collectPaths [path]+            paths `shouldBe` [path]+++--------------------------------------------------------------------------------+-- Helpers+--------------------------------------------------------------------------------++-- | Run the scripted interpreter, collecting all callback-delivered paths.+-- Uses a semaphore to wait for exactly N events before cancelling the watcher.+collectPaths :: [FilePath] -> IO [FilePath]+collectPaths = collectPathsWith []+++collectPathsWith :: [Watch] -> [FilePath] -> IO [FilePath]+collectPathsWith watches scripted = do+    ref <- newIORef []+    sem <- newQSem 0+    tid <- forkIO $ void $ runScripted scripted $ watchFilePaths watches \filePath _fileEvent -> liftIO do+        modifyIORef ref (<> [filePath])+        signalQSem sem+    replicateM_ (length scripted) (waitQSem sem)+    killThread tid+    readIORef ref+++runScripted :: [FilePath] -> Eff '[FileWatcher, Concurrent, IOE] a -> IO a+runScripted paths = runEff . runConcurrent . runFileWatcherScripted (map (,Modified) paths)+++--------------------------------------------------------------------------------+-- Properties+--------------------------------------------------------------------------------++propAntichain :: PropertyT IO ()+propAntichain = do+    dirs <- forAll genDirs+    let result = deduplicateDirs dirs+    let pairs = [(a, b) | a <- result, b <- result, a /= b]+    all (\(a, b) -> not (isStrictAncestor a b)) pairs === True+++propCoverage :: PropertyT IO ()+propCoverage = do+    dirs <- forAll genDirs+    let result = deduplicateDirs dirs+    all (isCoveredBy result) dirs === True+++propIdempotent :: PropertyT IO ()+propIdempotent = do+    dirs <- forAll genDirs+    deduplicateDirs (deduplicateDirs dirs) === deduplicateDirs dirs+++propSubset :: PropertyT IO ()+propSubset = do+    dirs <- forAll genDirs+    let result = deduplicateDirs dirs+    all (`elem` dirs) result === True+++--------------------------------------------------------------------------------+-- Generators+--------------------------------------------------------------------------------++genDirs :: Gen [FilePath]+genDirs = Gen.list (Range.linear 0 10) genAbsDir+++-- Generates absolute paths like /a/b/c using short segments to encourage+-- overlaps between generated paths.+genAbsDir :: Gen FilePath+genAbsDir = do+    segments <- Gen.list (Range.linear 1 4) genSegment+    pure $ "/" <> intercalate "/" segments+++genSegment :: Gen String+genSegment = Gen.string (Range.linear 1 3) (Gen.element ['a', 'b', 'c', 'd'])+++--------------------------------------------------------------------------------+-- Helpers (mirror of FileWatcher internals)+--------------------------------------------------------------------------------++isStrictAncestor :: FilePath -> FilePath -> Bool+isStrictAncestor parent child = (parent <> "/") `isPrefixOf` child+++isCoveredBy :: [FilePath] -> FilePath -> Bool+isCoveredBy result d = any (\r -> r == d || isStrictAncestor r d) result
+ test/Unit/Atelier/Effects/IteratorSpec.hs view
@@ -0,0 +1,118 @@+module Unit.Atelier.Effects.IteratorSpec (spec_Iterator) where++import Control.Concurrent (threadDelay)+import Effectful (IOE, runEff)+import Effectful.Concurrent (Concurrent, runConcurrent)+import Test.Hspec (Spec, describe, it, shouldBe)++import Atelier.Effects.Chan (Chan, runChan)+import Atelier.Effects.Clock (Clock, runClock)+import Atelier.Effects.Conc (Conc, fork, runConc)+import Atelier.Effects.Monitoring.Tracing (Tracing, runTracingNoOp)+import Atelier.Effects.Publishing (Pub, Sub, publish, runPubSub)++import Atelier.Effects.Iterator qualified as Iter+++spec_Iterator :: Spec+spec_Iterator = do+    describe "fromEvents" testFromEvents+    describe "filter" testFilter+    describe "changes" testChanges+++testFromEvents :: Spec+testFromEvents = do+    it "yields a published event" do+        result <- runTest $ do+            Iter.fromEvents @Int \iter -> do+                _ <- fork do+                    liftIO $ threadDelay 10+                    publish (42 :: Int)+                Iter.next iter+        result `shouldBe` 42++    it "yields events in publication order" do+        result <- runTest $ do+            Iter.fromEvents @Int \iter -> do+                _ <- fork do+                    liftIO $ threadDelay 10+                    traverse_ publish [1, 2, 3]+                replicateM 3 (Iter.next iter)+        result `shouldBe` [1, 2, 3]++    it "buffers events so next can catch up" do+        result <- runTest $ do+            Iter.fromEvents @Int \iter -> do+                _ <- fork do+                    liftIO $ threadDelay 10+                    traverse_ publish [1, 2, 3]+                liftIO $ threadDelay 5_000+                replicateM 3 (Iter.next iter)+        result `shouldBe` [1, 2, 3]+++testFilter :: Spec+testFilter = do+    it "passes values that satisfy the predicate" do+        result <- runTest $ do+            Iter.fromEvents @Int \iter -> do+                _ <- fork do+                    liftIO $ threadDelay 10+                    traverse_ publish [1 .. 4]+                Iter.next (Iter.filter even iter)+        result `shouldBe` 2++    it "skips values that do not satisfy the predicate" do+        result <- runTest $ do+            Iter.fromEvents @Int \iter -> do+                _ <- fork do+                    liftIO $ threadDelay 10+                    traverse_ publish [1 .. 6]+                replicateM 3 (Iter.next (Iter.filter even iter))+        result `shouldBe` [2, 4, 6]+++testChanges :: Spec+testChanges = do+    it "skips values equal to the initial value" do+        result <- runTest $ do+            Iter.fromEvents @Int \iter -> do+                _ <- fork do+                    liftIO $ threadDelay 10+                    traverse_ publish [0, 0, 1]+                Iter.next (Iter.changes 0 iter)+        result `shouldBe` 1++    it "yields values that differ from the initial value" do+        result <- runTest $ do+            Iter.fromEvents @Int \iter -> do+                _ <- fork do+                    liftIO $ threadDelay 10+                    traverse_ publish [1, 2, 3]+                replicateM 3 (Iter.next (Iter.changes 0 iter))+        result `shouldBe` [1, 2, 3]++    it "skips initial values interspersed with non-initial values" do+        result <- runTest $ do+            Iter.fromEvents @Int \iter -> do+                _ <- fork do+                    liftIO $ threadDelay 10+                    traverse_ publish [0, 1, 0, 2, 0, 3]+                replicateM 3 (Iter.next (Iter.changes 0 iter))+        result `shouldBe` [1, 2, 3]+++--------------------------------------------------------------------------------+-- Test Helpers+--------------------------------------------------------------------------------++runTest :: Eff '[Pub Int, Sub Int, Chan, Clock, Tracing, Conc, Concurrent, IOE] a -> IO a+runTest =+    runEff+        . runConcurrent+        . runConc+        . runTracingNoOp+        . runClock+        . runChan+        . runPubSub @Int
+ test/Unit/Atelier/Effects/LogSpec.hs view
@@ -0,0 +1,87 @@+module Unit.Atelier.Effects.LogSpec (spec_Log) where++import Effectful (runPureEff)+import Effectful.Writer.Static.Shared (Writer, execWriter)+import Test.Hspec (Spec, describe, it, shouldBe)++import Atelier.Effects.Log (Log, Message (..), info, runLogWriter, withNamespace)+++runLogTest :: Eff [Log, Writer [Message]] a -> [Message]+runLogTest =+    runPureEff+        . execWriter @[Message]+        . runLogWriter+++spec_Log :: Spec+spec_Log = do+    describe "Log with namespace" $ do+        it "logs without namespace when not provided" $ do+            let logs =+                    fmap (\m -> (m.namespace, m.text))+                        . runLogTest+                        $ info "test message"+            logs `shouldBe` [("", "test message")]++        it "prepends a namespace to the logged message" $ do+            let logs =+                    fmap (\m -> (m.namespace, m.text))+                        . runLogTest+                        . withNamespace "component"+                        $ info "test message"+            logs `shouldBe` [("component", "test message")]++        describe "nested namespaces" $ do+            it "appends a namespace to the current namespace" $ do+                let logs =+                        fmap (\m -> (m.namespace, m.text))+                            . runLogTest+                            . withNamespace "parent"+                            . withNamespace "child"+                            $ info "test message"+                logs `shouldBe` [("parent.child", "test message")]++            it "handles multiple levels of nesting" $ do+                let logs =+                        fmap (\m -> (m.namespace, m.text))+                            . runLogTest+                            . withNamespace "level1"+                            . withNamespace "level2"+                            . withNamespace "level3"+                            $ info "test message"+                logs `shouldBe` [("level1.level2.level3", "test message")]++        describe "namespace scoping" $ do+            it "only applies namespace within its scope" $ do+                let logs =+                        fmap (\m -> (m.namespace, m.text))+                            . runPureEff+                            . execWriter @[Message]+                            . runLogWriter+                            $ do+                                info "before"+                                withNamespace "scoped" $ info "inside"+                                info "after"+                logs+                    `shouldBe` [ ("", "before")+                               , ("scoped", "inside")+                               , ("", "after")+                               ]++            it "handles partially nested scopes" $ do+                let logs =+                        fmap (\m -> (m.namespace, m.text))+                            . runPureEff+                            . execWriter @[Message]+                            . runLogWriter+                            . withNamespace "outer"+                            $ do+                                info "outer msg"+                                withNamespace "inner" $ info "inner msg"+                                info "outer again"+                logs+                    `shouldBe` [ ("outer", "outer msg")+                               , ("outer.inner", "inner msg")+                               , ("outer", "outer again")+                               ]
+ test/Unit/Atelier/Effects/PublishingSpec.hs view
@@ -0,0 +1,105 @@+module Unit.Atelier.Effects.PublishingSpec (spec_Pub) where++import Control.Concurrent.MVar (newEmptyMVar, putMVar, takeMVar)+import Data.Time (UTCTime, getCurrentTime)+import Effectful (IOE, runEff, runPureEff)+import Effectful.Concurrent (Concurrent, runConcurrent)+import Effectful.Writer.Static.Shared (runWriter)+import Test.Hspec (Spec, context, describe, expectationFailure, it, shouldBe)++import Atelier.Effects.Chan (Chan, runChan)+import Atelier.Effects.Clock (Clock, runClock, runClockConst)+import Atelier.Effects.Conc (Conc, runConc)+import Atelier.Effects.Monitoring.Tracing (Tracing, runTracingNoOp)+import Atelier.Effects.Publishing (Pub, Sub, forkListener, forkListener_, publish, runPubSub, runPubWriter)+++data TestEvent = TestEvent Text+    deriving stock (Eq, Show)+++spec_Pub :: Spec+spec_Pub = do+    describe "Writer implementation" $ do+        context "no events published" do+            it "doesn't record events" $ do+                let ((), events) = runPureEff . runWriter . runPubWriter @TestEvent $ do+                        pure ()++                length events `shouldBe` 0++        context "events published" do+            it "records events" $ do+                let ((), events) = runPureEff . runWriter . runPubWriter @TestEvent $ do+                        publish $ TestEvent "payload"+                        pure ()++                length events `shouldBe` 1+                case events of+                    [TestEvent payload] ->+                        payload `shouldBe` "payload"+                    xs ->+                        expectationFailure $ "Expected 1 TestEvent event, got: " <> show (length xs)++    describe "PubSub implementation" do+        it "listener receives a published event" do+            result <- runPubSubTest $ do+                received <- liftIO newEmptyMVar+                forkListener_ @TestEvent \event ->+                    liftIO $ putMVar received event+                publish (TestEvent "hello")+                liftIO $ takeMVar received+            result `shouldBe` TestEvent "hello"++        it "event timestamp matches Clock at publish time" do+            t0 <- getCurrentTime+            result <- runPubSubTestWithClock t0 $ do+                received <- liftIO newEmptyMVar+                forkListener @TestEvent \ts _event ->+                    liftIO $ putMVar received ts+                publish (TestEvent "hello")+                liftIO $ takeMVar received+            result `shouldBe` t0++        it "multiple listeners each receive the published event" do+            result <- runPubSubTest $ do+                recv1 <- liftIO newEmptyMVar+                recv2 <- liftIO newEmptyMVar+                forkListener_ @TestEvent \event -> liftIO $ putMVar recv1 event+                forkListener_ @TestEvent \event -> liftIO $ putMVar recv2 event+                publish (TestEvent "hello")+                e1 <- liftIO $ takeMVar recv1+                e2 <- liftIO $ takeMVar recv2+                pure (e1, e2)+            result `shouldBe` (TestEvent "hello", TestEvent "hello")+++--------------------------------------------------------------------------------+-- Test Helpers+--------------------------------------------------------------------------------++runPubSubTest+    :: Eff '[Pub TestEvent, Sub TestEvent, Chan, Clock, Tracing, Conc, Concurrent, IOE] a+    -> IO a+runPubSubTest =+    runEff+        . runConcurrent+        . runConc+        . runTracingNoOp+        . runClock+        . runChan+        . runPubSub @TestEvent+++runPubSubTestWithClock+    :: UTCTime+    -> Eff '[Pub TestEvent, Sub TestEvent, Chan, Clock, Tracing, Conc, Concurrent, IOE] a+    -> IO a+runPubSubTestWithClock t =+    runEff+        . runConcurrent+        . runConc+        . runTracingNoOp+        . runClockConst t+        . runChan+        . runPubSub @TestEvent
+ test/Unit/Atelier/Effects/TallySpec.hs view
@@ -0,0 +1,109 @@+module Unit.Atelier.Effects.TallySpec (spec_Tally) where++import Effectful (IOE, runEff)+import Effectful.Concurrent (Concurrent, runConcurrent)+import Effectful.Reader.Static (Reader, runReader)+import Hedgehog (forAll, (===))+import Test.Hspec (Spec, describe, it, shouldBe)+import Test.Hspec.Hedgehog (hedgehog)++import Data.IORef qualified as IORef+import Data.Map.Strict qualified as Map+import Hedgehog.Gen qualified as Gen+import Hedgehog.Range qualified as Range++import Atelier.Effects.Clock (Clock, runClock)+import Atelier.Effects.Conc (Conc, runConc)+import Atelier.Effects.Delay (Delay, runDelay)+import Atelier.Effects.Log (Log, runLogNoOp)+import Atelier.Effects.Tally (Config (..), Tally, runTally, withTallyCheck)+++spec_Tally :: Spec+spec_Tally = do+    describe "Multiple Keys" do+        it "works with integer keys" do+            result <- runTallyTest $ checkCountsForKeys [1, 42, 999 :: Int]+            result `shouldBe` Map.fromList [(1, 1), (42, 1), (999, 1)]++    describe "Custom Classifiers" do+        it "identity classifier returns the raw hit count" do+            result <- runTallyTest $ replicateM 4 (withTallyCheck @Int 1 id pure)+            result `shouldBe` [1, 2, 3, 4 :: Int]++        it "multi-mark classifier yields correct mark for each hit" do+            -- Two thresholds: warning at >2, critical at >4+            let classify c+                    | c > 4 = Just True -- critical+                    | c > 2 = Just False -- warning+                    | otherwise = Nothing -- ok+            result <- runTallyTest $ replicateM 6 (withTallyCheck @Int 1 classify pure)+            result `shouldBe` [Nothing, Nothing, Just False, Just False, Just True, Just True]++        it "classifier producing tuples gives both count and flag" do+            let classify c = (c, c > 2)+            result <- runTallyTest $ replicateM 4 (withTallyCheck @Int 1 classify pure)+            result `shouldBe` [(1, False), (2, False), (3, True), (4, True)]++    describe "Action Execution" do+        it "continuation with side effects executes correctly" do+            result <- runTallyTest $ do+                ref <- liftIO $ IORef.newIORef ([] :: [(Int, Bool)])+                replicateM_ 3+                    $ withTallyCheck @Int 1 (\c -> (c, c > 2))+                    $ \(count, exceeded) ->+                        liftIO $ IORef.modifyIORef' ref ((count, exceeded) :)+                liftIO $ reverse <$> IORef.readIORef ref+            result `shouldBe` [(1, False), (2, False), (3, True)]++    describe "Properties" do+        it "kth call receives count k (count fidelity)" $ hedgehog $ do+            n <- forAll $ Gen.int (Range.linear 1 100)+            results <- liftIO $ runTallyTest $ replicateM n checkCount+            results === [1 .. n]++        it "no lost updates under concurrency" $ hedgehog $ do+            n <- forAll $ Gen.int (Range.linear 1 50)+            finalCount <- liftIO $ runTallyTest $ do+                replicateM_ n checkCount+                checkCount+            finalCount === n + 1++        it "classifier output is passed through unchanged" $ hedgehog $ do+            n <- forAll $ Gen.int (Range.linear 1 50)+            offset <- forAll $ Gen.int (Range.linear 0 200)+            results <- liftIO $ runTallyTest $ replicateM n (withTallyCheck @Int 1 (+ offset) pure)+            results === map (+ offset) [1 .. n]+++--------------------------------------------------------------------------------+-- Test Helpers+--------------------------------------------------------------------------------++-- | Run a tally test+runTallyTest :: Eff '[Tally Int, Reader Config, Clock, Delay, Conc, Log, Concurrent, IOE] a -> IO a+runTallyTest action =+    runEff+        . runConcurrent+        . runLogNoOp+        . runConc+        . runDelay+        . runClock+        . runReader (Config {entryTtl = 3600, cleanupInterval = 3600})+        . runTally @Int+        $ action+++-- | Increment the tally for the default test key and return the raw count+checkCount :: (Tally Int :> es) => Eff es Int+checkCount = withTallyCheck @Int 1 id pure+++-- | Increment the tally for a specific key and return the raw count+checkCountForKey :: (Hashable key, Ord key, Tally key :> es) => key -> Eff es Int+checkCountForKey key = withTallyCheck key id pure+++-- | Increment the tally for each key and return a map of key → count+checkCountsForKeys :: (Hashable key, Ord key, Tally key :> es) => [key] -> Eff es (Map key Int)+checkCountsForKeys keys = Map.fromList . zip keys <$> traverse checkCountForKey keys
+ test/Unit/Atelier/Effects/YieldSpec.hs view
@@ -0,0 +1,257 @@+module Unit.Atelier.Effects.YieldSpec (spec_Yield) where++import Effectful (runEff, runPureEff)+import Effectful.Concurrent (runConcurrent)+import Effectful.State.Static.Shared (execState, modify)+import Effectful.Writer.Static.Shared (execWriter, tell)+import Test.Hspec (Spec, describe, it, shouldBe, shouldMatchList)++import Atelier.Effects.Chan (runChan)+import Atelier.Effects.Conc (runConc)++import Atelier.Effects.Await qualified as Await+import Atelier.Effects.Yield qualified as Yield+++spec_Yield :: Spec+spec_Yield = do+    describe "yieldToList" testYieldToList+    describe "yieldToReverseList" testYieldToReverseList+    describe "forEach" testForEach+    describe "ignoreYield" testIgnoreYield+    describe "inFoldable" testInFoldable+    describe "cycleToYield" testCycleToYield+    describe "withYieldToList" testWithYieldToList+    describe "enumerate" testEnumerate+    describe "enumerateFrom" testEnumerateFrom+    describe "map" testMap+    describe "mapMaybe" testMapMaybe+    describe "catMaybes" testCatMaybes+    describe "filter" testFilter+    describe "changes" testChanges+++testYieldToList :: Spec+testYieldToList = do+    it "collects yields in order" do+        let ((), xs) = runPureEff $ Yield.yieldToList @Int do+                Yield.yield 1+                Yield.yield 2+                Yield.yield 3+        xs `shouldMatchList` [1, 2, 3]++    it "returns empty list when nothing is yielded" do+        let (_, xs) = runPureEff $ Yield.yieldToList @Int $ pure ()+        xs `shouldMatchList` []++    it "also returns the result of the computation" do+        let (r :: Text, xs) = runPureEff $ Yield.yieldToList do+                Yield.yield (1 :: Int)+                pure "result"+        r `shouldBe` "result"+        xs `shouldMatchList` [1]+++testYieldToReverseList :: Spec+testYieldToReverseList = do+    it "collects yields in reverse order" do+        let ((), xs) = runPureEff $ Yield.yieldToReverseList @Int do+                Yield.yield 1+                Yield.yield 2+                Yield.yield 3+        xs `shouldBe` [3, 2, 1]+++testForEach :: Spec+testForEach = do+    it "calls the action for each yielded value" do+        let xs = runPureEff+                $ execState @[Int] mempty+                $ Yield.forEach (\x -> modify (x :)) do+                    Yield.yield 1+                    Yield.yield 2+                    Yield.yield 3+        xs `shouldBe` [3, 2, 1]++    it "can discard values" do+        let xs = runPureEff $ Yield.forEach @Int (const $ pure ()) do+                Yield.yield 1+        xs `shouldBe` ()+++testIgnoreYield :: Spec+testIgnoreYield = do+    it "discards all yielded values" do+        let x = runPureEff $ Yield.ignoreYield @Int do+                Yield.yield 1+                Yield.yield 2+        x `shouldBe` ()+++testInFoldable :: Spec+testInFoldable = do+    it "yields all elements of a list in order" do+        let ((), xs) = runPureEff $ Yield.yieldToList $ Yield.inFoldable @Int [1, 2, 3]+        xs `shouldBe` [1, 2, 3]++    it "yields nothing for an empty list" do+        let ((), xs) = runPureEff $ Yield.yieldToList $ Yield.inFoldable @Int []+        xs `shouldBe` []+++testCycleToYield :: Spec+testCycleToYield = do+    it "yields elements of a list repeatedly in order" do+        xs <-+            runTest+                $ Await.awaitYield+                    (Yield.cycleToYield @Int [1, 2, 3])+                    (replicateM_ 7 (Await.await >>= \x -> tell [x]))+        xs `shouldBe` [1, 2, 3, 1, 2, 3, 1]+  where+    runTest = runEff . runConcurrent . runConc . runChan . execWriter+++testWithYieldToList :: Spec+testWithYieldToList = do+    it "passes the collected yields to the returned function" do+        let result = runPureEff $ Yield.withYieldToList @Int do+                Yield.yield 1+                Yield.yield 2+                Yield.yield 3+                pure length+        result `shouldBe` 3++    it "passes yields in order to the function" do+        let result = runPureEff $ Yield.withYieldToList @Int do+                Yield.yield 1+                Yield.yield 2+                Yield.yield 3+                pure id+        result `shouldBe` [1, 2, 3]++    it "passes an empty list when nothing is yielded" do+        let result = runPureEff $ Yield.withYieldToList @Int do+                pure null+        result `shouldBe` True+++testEnumerate :: Spec+testEnumerate = do+    it "pairs each value with its zero-based index" do+        let ((), xs) = runPureEff $ Yield.yieldToList $ Yield.enumerate do+                Yield.yield 'a'+                Yield.yield 'b'+                Yield.yield 'c'+        xs `shouldBe` [(0, 'a'), (1, 'b'), (2, 'c')]+++testEnumerateFrom :: Spec+testEnumerateFrom = do+    it "pairs each value with its index starting from the given value" do+        let ((), xs) = runPureEff $ Yield.yieldToList $ Yield.enumerateFrom 5 do+                Yield.yield 'x'+                Yield.yield 'y'+        xs `shouldBe` [(5, 'x'), (6, 'y')]+++testMap :: Spec+testMap = do+    it "transforms each yielded value" do+        let (_, xs) = runPureEff $ Yield.yieldToList $ Yield.map @Int (* 2) do+                Yield.yield 1+                Yield.yield 2+                Yield.yield 3+        xs `shouldBe` [2, 4, 6]++    it "preserves order" do+        let (_, xs :: [Text]) = runPureEff $ Yield.yieldToList $ Yield.map show do+                Yield.yield @Int 1+                Yield.yield 2+        xs `shouldBe` ["1", "2"]+++testMapMaybe :: Spec+testMapMaybe = do+    describe "when the function returns Just" $ it "yields transformed values" do+        let ((), xs) = runPureEff $ Yield.yieldToList $ Yield.mapMaybe (\x -> if even x then Just (x * 10) else Nothing) do+                Yield.yield @Int 1+                Yield.yield 2+                Yield.yield 3+                Yield.yield 4+        xs `shouldMatchList` [20, 40]++    describe "when the function always returns Nothing" $ it "yields nothing" do+        let (_, xs) = runPureEff $ Yield.yieldToList $ Yield.mapMaybe @Int @Int (const Nothing) do+                Yield.yield 1+        xs `shouldMatchList` []+++testCatMaybes :: Spec+testCatMaybes = do+    it "unwraps Just values and drops Nothings" do+        let (_, xs) = runPureEff $ Yield.yieldToList $ Yield.catMaybes do+                Yield.yield (Just 1)+                Yield.yield Nothing+                Yield.yield (Just 2)+        xs `shouldBe` [1 :: Int, 2]++    it "yields nothing when all values are Nothing" do+        let (_, xs) = runPureEff $ Yield.yieldToList $ Yield.catMaybes do+                Yield.yield (Nothing :: Maybe Int)+                Yield.yield Nothing+        xs `shouldBe` []+++testFilter :: Spec+testFilter = do+    it "passes values satisfying the predicate" do+        let (_, xs) = runPureEff $ Yield.yieldToList $ Yield.filter even do+                Yield.yield 1+                Yield.yield 2+                Yield.yield 3+                Yield.yield 4+        xs `shouldBe` [2 :: Int, 4]++    it "drops all values when predicate is always false" do+        let (_, xs) = runPureEff $ Yield.yieldToList $ Yield.filter (const False) do+                Yield.yield (1 :: Int)+        xs `shouldBe` []++    it "passes all values when predicate is always true" do+        let (_, xs) = runPureEff $ Yield.yieldToList $ Yield.filter (const True) do+                Yield.yield 1+                Yield.yield 2+        xs `shouldBe` [1 :: Int, 2]+++testChanges :: Spec+testChanges = do+    it "suppresses yields equal to the initial value" do+        let (_, xs) = runPureEff $ Yield.yieldToList $ Yield.changes 0 do+                Yield.yield 0+                Yield.yield 1+        xs `shouldBe` [1 :: Int]++    it "passes values that differ from the initial value" do+        let (_, xs) = runPureEff $ Yield.yieldToList $ Yield.changes 0 do+                Yield.yield 1+                Yield.yield 2+        xs `shouldBe` [1 :: Int, 2]++    it "suppresses initial value interspersed with other values" do+        let (_, xs) = runPureEff $ Yield.yieldToList $ Yield.changes 0 do+                Yield.yield 0+                Yield.yield 1+                Yield.yield 0+                Yield.yield 2+                Yield.yield 0+                Yield.yield 3+        xs `shouldBe` [1 :: Int, 2, 3]++    it "does not suppress non-initial values even if they repeat" do+        let (_, xs) = runPureEff $ Yield.yieldToList $ Yield.changes 0 do+                Yield.yield 1+                Yield.yield 1+                Yield.yield 2+        xs `shouldBe` [1 :: Int, 1, 2]
+ test/Unit/Atelier/Types/Semaphore/STMSpec.hs view
@@ -0,0 +1,126 @@+module Unit.Atelier.Types.Semaphore.STMSpec (spec_Semaphore_STM) where++import Effectful (runEff)+import Effectful.Concurrent (runConcurrent)+import Effectful.Concurrent.STM (atomically)+import Effectful.State.Static.Shared (evalState, get, put)+import Test.Hspec (Spec, describe, it, shouldBe)++import Data.IORef qualified as IORef++import Atelier.Effects.Conc qualified as Conc+import Atelier.Types.Semaphore.STM qualified as Sem+++spec_Semaphore_STM :: Spec+spec_Semaphore_STM = do+    describe "wait" $ it "should halt the computation" do+        runEff . runConcurrent . Conc.runConc . evalState @Int 0 $ do+            sem <- atomically Sem.new++            thread <- Conc.fork do+                atomically $ Sem.wait sem+                put 1++            a1 <- get+            liftIO $ a1 `shouldBe` 0++            atomically $ Sem.signal sem++            Conc.await thread++            a2 <- get+            liftIO $ a2 `shouldBe` 1++    describe "signal" do+        it "sets the semaphore" do+            result <- runEff . runConcurrent . atomically $ do+                sem <- Sem.new+                Sem.signal sem+                Sem.peek sem+            result `shouldBe` True++    describe "clear" do+        describe "when the semaphore was set" $ it "returns True" do+            result <- runEff . runConcurrent . atomically $ do+                sem <- Sem.newSet+                Sem.unset sem+            result `shouldBe` True++        describe "when the semaphore was not set" $ it "returns False" do+            result <- runEff . runConcurrent . atomically $ do+                sem <- Sem.new+                Sem.unset sem+            result `shouldBe` False++        it "leaves the semaphore clear" do+            result <- runEff . runConcurrent . atomically $ do+                sem <- Sem.newSet+                _ <- Sem.unset sem+                Sem.peek sem+            result `shouldBe` False++    describe "reset" do+        describe "when the semaphore was not set" $ it "returns True" do+            result <- runEff . runConcurrent . atomically $ do+                sem <- Sem.new+                Sem.set sem+            result `shouldBe` True++        describe "when the semaphore was already set" $ it "returns False" do+            result <- runEff . runConcurrent . atomically $ do+                sem <- Sem.newSet+                Sem.set sem+            result `shouldBe` False++        it "leaves the semaphore set" do+            result <- runEff . runConcurrent . atomically $ do+                sem <- Sem.new+                _ <- Sem.set sem+                Sem.peek sem+            result `shouldBe` True++    describe "peek" do+        describe "when the semaphore is set" $ it "returns True" do+            result <- runEff . runConcurrent . atomically $ do+                sem <- Sem.newSet+                Sem.peek sem+            result `shouldBe` True++        describe "when the semaphore is not set" $ it "returns False" do+            result <- runEff . runConcurrent . atomically $ do+                sem <- Sem.new+                Sem.peek sem+            result `shouldBe` False++        it "does not change the state of the semaphore" do+            (before, after) <- runEff . runConcurrent . atomically $ do+                sem <- Sem.newSet+                before <- Sem.peek sem+                after <- Sem.peek sem+                pure (before, after)+            (before, after) `shouldBe` (True, True)++    describe "withSemaphore" do+        it "returns the result of the enclosed computation" do+            result <- runEff . runConcurrent $ do+                sem <- atomically Sem.newSet+                Sem.withSemaphore sem $ pure (42 :: Int)+            result `shouldBe` 42++        it "signals the semaphore after the computation" do+            result <- runEff . runConcurrent $ do+                sem <- atomically Sem.newSet+                Sem.withSemaphore sem $ pure ()+                atomically $ Sem.peek sem+            result `shouldBe` True++        it "waits for the semaphore before running" do+            result <- runEff . runConcurrent . Conc.runConc $ do+                sem <- atomically Sem.new+                ref <- liftIO $ IORef.newIORef False+                _ <- Conc.fork $ do+                    liftIO $ IORef.writeIORef ref True+                    atomically $ Sem.signal sem+                Sem.withSemaphore sem $ liftIO $ IORef.readIORef ref+            result `shouldBe` True
+ test/Unit/Atelier/Types/SemaphoreSpec.hs view
@@ -0,0 +1,125 @@+module Unit.Atelier.Types.SemaphoreSpec (spec_Semaphore) where++import Effectful (runEff)+import Effectful.Concurrent (runConcurrent)+import Effectful.State.Static.Shared (evalState, get, put)+import Test.Hspec (Spec, describe, it, shouldBe)++import Data.IORef qualified as IORef++import Atelier.Effects.Conc qualified as Conc+import Atelier.Types.Semaphore qualified as Sem+++spec_Semaphore :: Spec+spec_Semaphore = do+    describe "wait" $ it "should halt the computation" do+        runEff . runConcurrent . Conc.runConc . evalState @Int 0 $ do+            sem <- Sem.new++            thread <- Conc.fork do+                Sem.wait sem+                put 1++            a1 <- get+            liftIO $ a1 `shouldBe` 0++            Sem.signal sem++            Conc.await thread++            a2 <- get+            liftIO $ a2 `shouldBe` 1++    describe "signal" do+        it "sets the semaphore" do+            result <- runEff . runConcurrent $ do+                sem <- Sem.new+                Sem.signal sem+                Sem.peek sem+            result `shouldBe` True++    describe "clear" do+        describe "when the semaphore was set" $ it "returns True" do+            result <- runEff . runConcurrent $ do+                sem <- Sem.newSet+                Sem.unset sem+            result `shouldBe` True++        describe "when the semaphore was not set" $ it "returns False" do+            result <- runEff . runConcurrent $ do+                sem <- Sem.new+                Sem.unset sem+            result `shouldBe` False++        it "leaves the semaphore clear" do+            result <- runEff . runConcurrent $ do+                sem <- Sem.newSet+                _ <- Sem.unset sem+                Sem.peek sem+            result `shouldBe` False++    describe "reset" do+        describe "when the semaphore was not set" $ it "returns True" do+            result <- runEff . runConcurrent $ do+                sem <- Sem.new+                Sem.set sem+            result `shouldBe` True++        describe "when the semaphore was already set" $ it "returns False" do+            result <- runEff . runConcurrent $ do+                sem <- Sem.newSet+                Sem.set sem+            result `shouldBe` False++        it "leaves the semaphore set" do+            result <- runEff . runConcurrent $ do+                sem <- Sem.new+                _ <- Sem.set sem+                Sem.peek sem+            result `shouldBe` True++    describe "peek" do+        describe "when the semaphore is set" $ it "returns True" do+            result <- runEff . runConcurrent $ do+                sem <- Sem.newSet+                Sem.peek sem+            result `shouldBe` True++        describe "when the semaphore is not set" $ it "returns False" do+            result <- runEff . runConcurrent $ do+                sem <- Sem.new+                Sem.peek sem+            result `shouldBe` False++        it "does not change the state of the semaphore" do+            (before, after) <- runEff . runConcurrent $ do+                sem <- Sem.newSet+                before <- Sem.peek sem+                after <- Sem.peek sem+                pure (before, after)+            (before, after) `shouldBe` (True, True)++    describe "withSemaphore" do+        it "returns the result of the enclosed computation" do+            result <- runEff . runConcurrent $ do+                sem <- Sem.newSet+                Sem.withSemaphore sem $ pure (42 :: Int)+            result `shouldBe` 42++        it "signals the semaphore after the computation" do+            result <- runEff . runConcurrent $ do+                sem <- Sem.newSet+                Sem.withSemaphore sem $ pure ()+                Sem.peek sem+            result `shouldBe` True++        it "waits for the semaphore before running" do+            result <- runEff . runConcurrent . Conc.runConc $ do+                sem <- Sem.new+                ref <- liftIO $ IORef.newIORef False+                _ <- Conc.fork $ do+                    liftIO $ IORef.writeIORef ref True+                    Sem.signal sem+                Sem.withSemaphore sem $ liftIO $ IORef.readIORef ref+            result `shouldBe` True
+ test/Unit/Atelier/Types/WithDefaultsSpec.hs view
@@ -0,0 +1,63 @@+module Unit.Atelier.Types.WithDefaultsSpec (spec_WithDefaults) where++import Data.Aeson (FromJSON, ToJSON, eitherDecode)+import Data.Default (Default (..))+import Test.Hspec++import Data.ByteString.Lazy qualified as LBS++import Atelier.Types.QuietSnake (QuietSnake (..))+import Atelier.Types.WithDefaults (WithDefaults (..))+++-- | A minimal fixture type with non-Maybe list fields to exercise WithDefaults.+data Fixture = Fixture+    { requiredField :: Text+    , items :: [Text]+    , count :: Int+    }+    deriving stock (Eq, Generic, Show)+    deriving (FromJSON, ToJSON) via QuietSnake Fixture+++instance Default Fixture where+    def =+        Fixture+            { requiredField = "default-value"+            , items = ["default-item"]+            , count = 0+            }+++decodeWithDefaults :: LBS.ByteString -> Either String Fixture+decodeWithDefaults bs = getQuietSnake . getWithDefaults <$> eitherDecode @(WithDefaults (QuietSnake Fixture)) bs+++spec_WithDefaults :: Spec+spec_WithDefaults = do+    describe "WithDefaults" do+        it "falls back to Default values for missing non-Maybe fields" do+            let result = decodeWithDefaults "{}"+            result `shouldBe` Right def++        it "uses provided values when all fields are present" do+            let result =+                    decodeWithDefaults+                        "{\"required_field\": \"hello\", \"items\": [\"a\", \"b\"], \"count\": 42}"+            result+                `shouldBe` Right+                    Fixture+                        { requiredField = "hello"+                        , items = ["a", "b"]+                        , count = 42+                        }++        it "partial object: provided fields override defaults, missing fall back" do+            let result = decodeWithDefaults "{\"count\": 7}"+            result+                `shouldBe` Right+                    def {count = 7}++        it "explicitly provided empty list overrides the default list" do+            let result = decodeWithDefaults "{\"items\": []}"+            result `shouldBe` Right def {items = []}