atelier-core 0.8.1.0 → 1.0.0.0

raw patch · 67 files changed

+1508/−1125 lines, 67 filesPVP ok

version bump matches the API change (PVP)

API changes (from Hackage documentation)

Files

• CHANGELOG.md +68/−0
• atelier-core.cabal +13/−10
• src/Atelier/Config.hs +4/−2
• src/Atelier/Effects/Arguments.hs +18/−12
• src/Atelier/Effects/Arguments/Switch.hs +58/−0
• src/Atelier/Effects/Cache.hs +27/−27
• src/Atelier/Effects/Cache/Singleflight.hs +12/−12
• src/Atelier/Effects/Chan.hs +20/−20
• src/Atelier/Effects/Clock.hs +12/−12
• src/Atelier/Effects/Conc.hs +20/−24
• src/Atelier/Effects/Console.hs +14/−14
• src/Atelier/Effects/Debounce.hs +38/−26
• src/Atelier/Effects/Delay.hs +8/−23
• src/Atelier/Effects/Env.hs +16/−18
• src/Atelier/Effects/Exit.hs +15/−19
• src/Atelier/Effects/FSNotify.hs +113/−0
• src/Atelier/Effects/FSNotify/Devel.hs +33/−0
• src/Atelier/Effects/File.hs +6/−11
• src/Atelier/Effects/FileSystem.hs +23/−9
• src/Atelier/Effects/FileWatcher.hs +55/−158
• src/Atelier/Effects/FileWatcher/Event.hs +49/−0
• src/Atelier/Effects/FileWatcher/Watch.hs +95/−0
• src/Atelier/Effects/GenUUID.hs +38/−0
• src/Atelier/Effects/Input.hs +6/−27
• src/Atelier/Effects/Internal/Coroutine.hs +3/−3
• src/Atelier/Effects/Iterator.hs +3/−3
• src/Atelier/Effects/Log.hs +33/−20
• src/Atelier/Effects/Posix/Daemons.hs +44/−28
• src/Atelier/Effects/Process.hs +65/−43
• src/Atelier/Effects/Process/Internal.hs +1/−1
• src/Atelier/Effects/PubSub.hs +4/−4
• src/Atelier/Effects/PubSub/Pub.hs +3/−3
• src/Atelier/Effects/PubSub/Sub.hs +3/−1
• src/Atelier/Effects/Publishing.hs +0/−18
• src/Atelier/Effects/Publishing/Pub.hs +0/−8
• src/Atelier/Effects/Publishing/Sub.hs +0/−8
• src/Atelier/Effects/Tally.hs +30/−43
• src/Atelier/Effects/Timeout.hs +50/−30
• src/Atelier/Effects/UUID.hs +0/−38
• src/Atelier/Types/Base64.hs +0/−33
• src/Atelier/Types/JSON/Base64.hs +33/−0
• src/Atelier/Types/JSON/Renamed.hs +23/−0
• src/Atelier/Types/JSON/WithDefaults.hs +40/−0
• src/Atelier/Types/JsonReadShow.hs +0/−12
• src/Atelier/Types/QuietSnake.hs +0/−8
• src/Atelier/Types/WithDefaults.hs +0/−40
• test/Unit/Atelier/ConfigSpec.hs +1/−1
• test/Unit/Atelier/Effects/Arguments/SwitchSpec.hs +66/−0
• test/Unit/Atelier/Effects/AwaitSpec.hs +3/−4
• test/Unit/Atelier/Effects/Cache/SingleflightSpec.hs +47/−42
• test/Unit/Atelier/Effects/CacheSpec.hs +59/−63
• test/Unit/Atelier/Effects/ChanSpec.hs +31/−29
• test/Unit/Atelier/Effects/Conc/TeardownStressSpec.hs +14/−11
• test/Unit/Atelier/Effects/ConcSpec.hs +4/−4
• test/Unit/Atelier/Effects/ConsoleSpec.hs +7/−7
• test/Unit/Atelier/Effects/DebounceSpec.hs +34/−42
• test/Unit/Atelier/Effects/FileSystemSpec.hs +1/−1
• test/Unit/Atelier/Effects/FileWatcherSpec.hs +12/−12
• test/Unit/Atelier/Effects/IteratorSpec.hs +17/−14
• test/Unit/Atelier/Effects/LogSpec.hs +6/−4
• test/Unit/Atelier/Effects/PubSubSpec.hs +12/−9
• test/Unit/Atelier/Effects/TallySpec.hs +25/−40
• test/Unit/Atelier/Effects/YieldSpec.hs +3/−4
• test/Unit/Atelier/Types/JSON/WithDefaultsSpec.hs +66/−0
• test/Unit/Atelier/Types/Semaphore/STMSpec.hs +2/−2
• test/Unit/Atelier/Types/SemaphoreSpec.hs +2/−2
• test/Unit/Atelier/Types/WithDefaultsSpec.hs +0/−66

@@ -7,6 +7,74 @@  ## [Unreleased] +## [1.0.0.0] - 2026-10-29++### Added++- `Atelier.Effects.FSNotify`: `System.FSNotify` lifted to `Eff`.+- `Atelier.Types.JSON.Renamed`: used to mark properties that have been renamed.+  Attempting to JSON parse a property that is `Renamed "from" "to"` will+  produce an error message denoting that the property `"from"` has been renamed+  to `"to"`.+- `Atelier.Effects.Arguments.Switch`: similar to `Options.Applicative.switch`+  from `optparse-applicative`, but includes an inverse flag in the form of+  `--no-<long-name>` for the flag.++### Changed++- `Atelier.Effects.Arguments`: converted to a static effect.+- `Atelier.Effects.Arguments.runArgumentsIO` renamed to+  `Atelier.Effects.Arguments.runIO`.+- `Atelier.Types.Base64` moved to `Atelier.Types.JSON.Base64`.+- `Atelier.Types.WithDefaults` moved to `Atelier.Types.JSON.WithDefaults`.+- `Atelier.Effects.Cache`: renamed members to make more suited for qualified+  use.+- `Atelier.Effects.Chan`: renamed members to make more suited for qualified+  use.+- `Atelier.Effects.Clock`: renamed members to make more suited for qualified+  use.+- `Atelier.Effects.Conc`: renamed members to make more suited for qualified+  use.+- `Atelier.Effects.Console`: renamed members to make more suited for qualified+  use.+- `Atelier.Effects.Debounce`: renamed members to make more suited for qualified+  use.+- `Atelier.Effects.Delay`: renamed members to make more suited for qualified+  use.+- `Atelier.Effects.Env`: renamed members to make more suited for qualified use.+- `Atelier.Effects.Exit`: renamed members to make more suited for qualified+  use.+- `Atelier.Effects.File`: renamed members to make more suited for qualified+  use.+- `Atelier.Effects.FileSystem`: renamed members to make more suited for+  qualified use.+- `Atelier.Effects.FileWatcher`: renamed members to make more suited for+  qualified use.+- `Atelier.Effects.Log`: renamed members to make more suited for qualified use.+- `Atelier.Effects.Process`: converted to static effect, and renamed members to+  make more suited for qualified use.+- `Atelier.Effects.Tally`: renamed members to make more suited for qualified+  use.+- `Atelier.Effects.Tally.count` (previously+  `Atelier.Effects.Tally.withTallyCheck`) now no longer takes a classifier. The+  classifier function was always just ran and passed straight through to the+  continuation, so now the continuation just receives the count as-is.+- `Atelier.Effects.Timeout`: converted to static effect, and renamed members to+  make more suited for qualified use.+- `Atelier.Effects.UUID`: renamed to `Atelier.Effects.GenUUID`, and renamed+  members to make more suited for qualified use.+- `Atelier.Effects.Cache.Singleflight`: renamed members to make more suited for+  qualified use.+- `Atelier.Effects.Posix.Daemons`: converted to static effect, and renamed members to+  make more suited for qualified use.+- `Atelier.Effects.PubSub.Pub`: `runNoOp` renamed to `noOp`.++### Removed++- Deprecated functions in `Atelier.Effects.Input`.+- Deprecated modules `Atelier.Effects.Publishing`,+  `Atelier.Effects.Publishing.Sub` and `Atelier.Effects.Publishing.Pub`.+ ## [0.8.1.0] - 2026-10-23  ### Added

@@ -5,7 +5,7 @@ -- see: https://github.com/sol/hpack  name:           atelier-core-version:        0.8.1.0+version:        1.0.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@@ -34,6 +34,7 @@   exposed-modules:       Atelier.Config       Atelier.Effects.Arguments+      Atelier.Effects.Arguments.Switch       Atelier.Effects.Await       Atelier.Effects.Cache       Atelier.Effects.Cache.Config@@ -50,6 +51,11 @@       Atelier.Effects.FileSystem       Atelier.Effects.FileSystem.Glob       Atelier.Effects.FileWatcher+      Atelier.Effects.FileWatcher.Event+      Atelier.Effects.FileWatcher.Watch+      Atelier.Effects.FSNotify+      Atelier.Effects.FSNotify.Devel+      Atelier.Effects.GenUUID       Atelier.Effects.Input       Atelier.Effects.Internal.Coroutine       Atelier.Effects.Iterator@@ -58,30 +64,25 @@       Atelier.Effects.Posix.IO       Atelier.Effects.Process       Atelier.Effects.Process.Internal-      Atelier.Effects.Publishing-      Atelier.Effects.Publishing.Pub-      Atelier.Effects.Publishing.Sub       Atelier.Effects.PubSub       Atelier.Effects.PubSub.Pub       Atelier.Effects.PubSub.Sub       Atelier.Effects.Reader       Atelier.Effects.Tally       Atelier.Effects.Timeout-      Atelier.Effects.UUID       Atelier.Effects.Yield       Atelier.Exception       Atelier.Signal       Atelier.Time-      Atelier.Types.Base64       Atelier.Types.HttpApiDataReadShow+      Atelier.Types.JSON.Base64       Atelier.Types.JSON.QuietSnake       Atelier.Types.JSON.ReadShow+      Atelier.Types.JSON.Renamed       Atelier.Types.JSON.StringLiteral-      Atelier.Types.JsonReadShow-      Atelier.Types.QuietSnake+      Atelier.Types.JSON.WithDefaults       Atelier.Types.Semaphore       Atelier.Types.Semaphore.STM-      Atelier.Types.WithDefaults   other-modules:       Paths_atelier_core   autogen-modules:@@ -155,6 +156,7 @@   main-is: Driver.hs   other-modules:       Unit.Atelier.ConfigSpec+      Unit.Atelier.Effects.Arguments.SwitchSpec       Unit.Atelier.Effects.AwaitSpec       Unit.Atelier.Effects.Cache.SingleflightSpec       Unit.Atelier.Effects.CacheSpec@@ -171,9 +173,9 @@       Unit.Atelier.Effects.PubSubSpec       Unit.Atelier.Effects.TallySpec       Unit.Atelier.Effects.YieldSpec+      Unit.Atelier.Types.JSON.WithDefaultsSpec       Unit.Atelier.Types.Semaphore.STMSpec       Unit.Atelier.Types.SemaphoreSpec-      Unit.Atelier.Types.WithDefaultsSpec       Paths_atelier_core   autogen-modules:       Paths_atelier_core@@ -211,6 +213,7 @@     , effectful-core ==2.7.*     , effectful-plugin ==2.2.*     , hedgehog ==1.7.*+    , optparse-applicative ==0.19.*     , stm ==2.5.*     , stm-containers ==1.2.*     , tasty ==1.5.*

@@ -59,15 +59,17 @@ import Data.Text qualified as T import Data.Text.Encoding qualified as TE -import Atelier.Effects.Env (Env, getEnvironment)+import Atelier.Effects.Env (Env) +import Atelier.Effects.Env qualified as Env + -- | 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+    allEnv <- Env.all     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]

@@ -1,3 +1,5 @@+{-# OPTIONS_GHC -Wno-redundant-constraints #-}+ -- | Effect for parsing command-line arguments. -- -- A thin wrapper over @optparse-applicative@'s 'Opt.execParser', so callers@@ -13,28 +15,32 @@     , execParser        -- * Interpreters-    , runArgumentsIO+    , runIO     ) where -import Effectful (Effect, IOE)-import Effectful.Dispatch.Dynamic (interpret_)-import Effectful.TH (makeEffect)+import Effectful (Dispatch (..), DispatchOf, Effect, IOE)+import Effectful.Dispatch.Static (SideEffects (..), StaticRep, evalStaticRep, unsafeEff_) 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+data Arguments :: Effect  -makeEffect ''Arguments+type instance DispatchOf Arguments = Static WithSideEffects  -runArgumentsIO :: (IOE :> es) => Eff (Arguments : es) a -> Eff es a-runArgumentsIO = interpret_ \case-    ExecParser pinfo -> liftIO $ Opt.execParser pinfo+data instance StaticRep Arguments = Arguments+++-- \| Read @argv@ and parse it with the given parser, printing usage and+-- exiting on failure (see @optparse-applicative@'s 'Opt.execParser').+execParser :: (Arguments :> es) => ParserInfo a -> Eff es a+execParser = unsafeEff_ . Opt.execParser+++runIO :: (IOE :> es) => Eff (Arguments : es) a -> Eff es a+runIO = evalStaticRep Arguments

@@ -0,0 +1,58 @@+module Atelier.Effects.Arguments.Switch (parser) where++import Options.Applicative (FlagFields, Parser, flag', internal, long, style)+import Options.Applicative.Builder.Internal (FlagFields (..), Mod (..))+import Options.Applicative.Types (OptName (..))++import Data.List qualified as List+import Options.Applicative.Help qualified as Doc+++-- | Builder for a switch that has an inverse option as well in the form of+-- `--no-<flag-name>`. Automatically finds the long name and short name among+-- the options passed. If no long name is set, then `--no-<flag-name>` will not+-- be made available, and this parser behaves just like the regular `switch`+-- parser builder from `optparse-applicative`. The flags may be repeated, and+-- the last one given wins.+parser+    :: Mod FlagFields Bool+    -- ^ Extra flag options to use.+    -> Parser Bool+parser opts =+    fmap (maybe False last . nonEmpty)+        $ many+        $ maybe empty inactiveParser longName+            <|> activeParser shortName longName opts+  where+    Mod f _ _ = opts+    realOpts = f $ FlagFields [] False+    shortName =+        viaNonEmpty head+            $ mapMaybe+                ( \case+                    OptShort c -> Just c+                    _ -> Nothing+                )+                realOpts.flagNames+    longName =+        viaNonEmpty head+            $ mapMaybe+                ( \case+                    OptLong l -> Just l+                    _ -> Nothing+                )+                realOpts.flagNames+++activeParser :: Maybe Char -> Maybe String -> Mod FlagFields Bool -> Parser Bool+activeParser shortName longName opts =+    flag' True $ opts <> style (const displayName)+  where+    displayName = mconcat $ Doc.punctuate "," $ displayedShortName <> displayedLongName+    displayedShortName = maybe [] (one . Doc.pretty . ("-" <>) . List.singleton) shortName+    displayedLongName = maybe [] (one . Doc.pretty . ("--[no-]" <>)) longName+++inactiveParser :: String -> Parser Bool+inactiveParser longName =+    flag' False $ long ("no-" <> longName) <> internal

@@ -2,18 +2,18 @@ module Atelier.Effects.Cache     ( -- * Effect       Cache-    , cacheLookup-    , cacheInsert-    , cacheDelete-    , cacheModify+    , lookup+    , insert+    , delete+    , modify        -- * Re-exports     , module Atelier.Effects.Cache.Config        -- * Interpreters-    , runCacheTtl-    , runCacheTtlWithWait-    , runCacheForever+    , runTTL+    , runTTLWithWait+    , runForever     ) where @@ -46,14 +46,14 @@ -- | 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)+    Lookup :: key -> Cache key value m (Maybe value)     -- | Insert or overwrite the value at a key.-    CacheInsert :: key -> value -> Cache key value m ()+    Insert :: key -> value -> Cache key value m ()     -- | Remove a key from the cache.-    CacheDelete :: key -> Cache key value m ()+    Delete :: 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+    Modify :: key -> (Maybe value -> value) -> Cache key value m value   makeEffect ''Cache@@ -71,7 +71,7 @@ -- 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+runTTL     :: forall key value es a      . ( Clock :> es        , Conc :> es@@ -82,16 +82,16 @@        , Reader Config :> es        )     => Eff (Cache key value : es) a -> Eff es a-runCacheTtl act = do+runTTL act = do     cfg <- ask-    runCacheTtlWithWait (Delay.wait $ nominalDiffTime @Microsecond cfg.cleanupInterval) act+    runTTLWithWait (Delay.wait $ nominalDiffTime @Microsecond cfg.cleanupInterval) act  --- | Like 'runCacheTtl', but with the cleanup cadence supplied explicitly as a+-- | Like 'runTtl', 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+runTTLWithWait     :: forall key value es a      . ( Clock :> es        , Conc :> es@@ -104,7 +104,7 @@     -- ^ Action that completes when it is time to perform cleanup.     -> Eff (Cache key value : es) a     -> Eff es a-runCacheTtlWithWait waitForNextCleanup action = do+runTTLWithWait waitForNextCleanup action = do     cfg <- ask @Config     store <- STM.atomically (Map.new :: STM (Map key (CacheEntry value))) @@ -118,9 +118,9 @@             $ "Evicted " <> show evicted <> " entries"      interpretWith action $ \_ -> \case-        CacheLookup key ->+        Lookup key ->             fmap (.value) <$> STM.atomically (Map.lookup key store)-        CacheInsert key val -> do+        Insert key val -> do             now <- currentTime             STM.atomically $ do                 existing <- Map.lookup key store@@ -128,9 +128,9 @@                         Nothing -> CacheEntry {value = val, createdAt = now}                         Just e -> e {value = val} -- preserve original timestamp                 Map.insert entry key store-        CacheDelete key ->+        Delete key ->             STM.atomically $ Map.delete key store-        CacheModify key f -> do+        Modify key f -> do             now <- currentTime             STM.atomically $ do                 existing <- Map.lookup key store@@ -164,21 +164,21 @@ -- -- Uses a plain STM 'Map' with no eviction. Useful for tests and -- session-scoped caches where eviction is never needed.-runCacheForever+runForever     :: forall key value es a      . (Concurrent :> es, Hashable key)     => Eff (Cache key value : es) a     -> Eff es a-runCacheForever action = do+runForever action = do     store <- STM.atomically (Map.new :: STM (Map key value))     interpretWith action $ \_ -> \case-        CacheLookup key ->+        Lookup key ->             STM.atomically $ Map.lookup key store-        CacheInsert key val ->+        Insert key val ->             STM.atomically $ Map.insert val key store-        CacheDelete key ->+        Delete key ->             STM.atomically $ Map.delete key store-        CacheModify key f ->+        Modify key f ->             STM.atomically $ do                 existing <- Map.lookup key store                 let newVal = f existing

@@ -7,10 +7,10 @@ -- be seeded with 'updateCache' or invalidated with 'removeFromCache'. module Atelier.Effects.Cache.Singleflight     ( Singleflight (..)-    , withCache-    , updateCache-    , removeFromCache-    , runSingleflight+    , with+    , update+    , remove+    , runIO     ) where @@ -36,12 +36,12 @@ 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+    With :: (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 ()+    Update :: [(key, value)] -> Singleflight key value m ()     -- | Remove keys from the cache so future requests recompute from source-    RemoveFromCache :: [key] -> Singleflight key value m ()+    Remove :: [key] -> Singleflight key value m ()   makeEffect ''Singleflight@@ -51,18 +51,18 @@   -- | Run the Singleflight effect with an in-memory cache-runSingleflight+runIO     :: forall key value es a      . (Concurrent :> es, Hashable key)     => Eff (Singleflight key value : es) a     -> Eff es a-runSingleflight action = do+runIO 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 -> do+        With key computation -> localSeqUnlift env $ \unlift -> 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@@ -115,7 +115,7 @@                     case result of                         Left exception -> throwIO exception                         Right value -> pure value-        UpdateCache entries -> do+        Update entries -> do             STM.atomically $ do                 forM_ entries $ \(key, value) -> do                     existing <- Map.lookup key cache@@ -130,5 +130,5 @@                             -- No in-flight computation: create fresh TMVar with value                             tmvar <- STM.newTMVar (Right value)                             Map.insert tmvar key cache-        RemoveFromCache keys -> do+        Remove keys -> do             STM.atomically $ forM_ keys $ \key -> Map.delete key cache

@@ -26,11 +26,12 @@ module Atelier.Effects.Chan     ( -- * Effect       Chan-    , newChan-    , readChan-    , writeChan-    , dupChan-    , runChan+    , new+    , read+    , write+    , dup+    , run+    , readBatched        -- * Channel Types @@ -39,7 +40,6 @@       -- to maintain abstraction boundaries.     , InChan     , OutChan-    , readChanBatched     ) where @@ -64,33 +64,33 @@   -- | 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+run :: forall a es. (IOE :> es) => Eff (Chan : es) a -> Eff es a+run = 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 =+new :: forall a es. (Chan :> es) => Eff es (InChan a, OutChan a)+new =     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 =+read :: forall a es. (Chan :> es) => OutChan a -> Eff es a+read 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 =+write :: forall a es. (Chan :> es) => InChan a -> a -> Eff es ()+write 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 =+dup :: forall a es. (Chan :> es) => InChan a -> Eff es (OutChan a)+dup inChan =     unsafeEff_ $ Unagi.dupChan inChan  @@ -99,7 +99,7 @@ -- 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+readBatched     :: forall t a es      . ( Chan :> es        , TimeUnit t@@ -113,13 +113,13 @@     -- ^ 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+readBatched timeoutDuration batchSize outChan = do     evalState @[a] [] $ do-        h <- readChan outChan -- blocking, get first item+        h <- read outChan -- blocking, get first item         _ <- timeout (fromIntegral (toMicroseconds timeoutDuration))             $ replicateM_ (batchSize - 1)             $ do-                x <- readChan outChan+                x <- read outChan                 modify (x :)         rest <- get         pure $ h :| reverse rest

@@ -9,10 +9,10 @@     , TimeZone     , currentTime     , currentTimeZone-    , runClock-    , runClockConst-    , runClockState-    , runClockList+    , runIO+    , runConst+    , runState+    , runList     ) where @@ -36,24 +36,24 @@   -- | Interpret 'Clock' against the real system clock.-runClock :: (IOE :> es) => Eff (Clock : es) a -> Eff es a-runClock = interpret_ $ \case+runIO :: (IOE :> es) => Eff (Clock : es) a -> Eff es a+runIO = 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+runConst :: UTCTime -> Eff (Clock : es) a -> Eff es a+runConst 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+runState :: (State UTCTime :> es) => Eff (Clock : es) a -> Eff es a+runState = interpret_ $ \case     CurrentTime -> get     CurrentTimeZone -> pure utc @@ -61,8 +61,8 @@ -- | 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+runList :: [UTCTime] -> Eff (Clock : es) a -> Eff es a+runList times = reinterpret (evalState times) $ \_ -> \case     CurrentTime ->         get >>= \case             [] -> error "runClockList: no more times in queue"

@@ -3,8 +3,7 @@ -- '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.+-- scope closes. module Atelier.Effects.Conc     ( -- * Effect       Conc (..)@@ -24,11 +23,11 @@     , restartableForkLoop        -- * Interpreters-    , runConcBase-    , runConc+    , runScope+    , runIO        -- * Unlift Strategy-    , concStrat+    , strategy     ) where @@ -134,30 +133,27 @@   -- | 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+runScope :: forall es a. (Concurrent :> es, IOE :> es) => Scope -> Eff (Conc : es) a -> Eff es a+runScope (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 ->+            localUnliftIO env strategy \unlift ->                 fmap Thread . liftIO . Ki.fork scope $ unlift action         Fork_ action ->-            localUnliftIO env concStrat \unlift ->+            localUnliftIO env strategy \unlift ->                 Ki.fork_ scope $ unlift action         ForkTry action ->-            localUnliftIO env concStrat \unlift ->+            localUnliftIO env strategy \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 ->+            localLend @'[Concurrent] env strategy \lend ->+                localUnliftIO env strategy \unlift ->                     Ki.scoped \raceScope -> do                         ref <- unlift $ inject $ lend newEmptyMVar                         void@@ -170,9 +166,9 @@                             $ lend . putMVar ref . Right =<< mb                         unlift $ lend $ takeMVar ref         Scoped m ->-            localUnlift env concStrat \unliftEff ->-                localLend @'[IOE, Concurrent] env concStrat \lend ->-                    withEffToIO concStrat \unliftIO ->+            localUnlift env strategy \unliftEff ->+                localLend @'[IOE, Concurrent] env strategy \lend ->+                    withEffToIO strategy \unliftIO ->                         Ki.scoped \subScope ->                             unliftIO                                 . unliftEff@@ -185,14 +181,14 @@ -- | 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 ->+runIO :: (Concurrent :> es, IOE :> es) => Eff (Conc : es) a -> Eff es a+runIO eff = withEffToIO strategy $ \unlift ->     Ki.scoped $ \scope ->-        unlift $ runConcBase (Scope scope) eff+        unlift $ runScope (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+-- of the enclosing computation.+strategy :: UnliftStrategy+strategy = ConcUnlift Persistent Unlimited

@@ -13,10 +13,10 @@     , putText        -- * Interpreters-    , runConsoleHandle-    , runConsole-    , runConsoleToList-    , runConsoleOut+    , runHandle+    , runIO+    , runToList+    , runOut     ) where @@ -58,24 +58,24 @@   -- | Interpret 'Console' by writing to the given 'Handle'.-runConsoleHandle :: (IOE :> es) => Handle -> Eff (Console : es) a -> Eff es a-runConsoleHandle h = interpret_ \case+runHandle :: (IOE :> es) => Handle -> Eff (Console : es) a -> Eff es a+runHandle 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+runIO :: (IOE :> es) => Eff (Console : es) a -> Eff es a+runIO = runHandle 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+runToList :: Eff (Console : es) a -> Eff es (a, [ByteString])+runToList = reinterpret_ (fmap (second reverse) . runState []) \case     PutStr s -> modify (s :)  -runConsoleOut :: (IOE :> es) => Output -> Eff (Console : es) a -> Eff es a-runConsoleOut = \case-    Stderr -> runConsoleHandle stderr-    Stdout -> runConsoleHandle stdout+runOut :: (IOE :> es) => Output -> Eff (Console : es) a -> Eff es a+runOut = \case+    Stderr -> runHandle stderr+    Stdout -> runHandle stdout

@@ -2,11 +2,11 @@ -- -- == Overview ----- 'debouncedWith' is the fundamental operation: it accumulates rapid successive+-- 'with' 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+-- 'debounce' is a convenience wrapper for the common case where only timing -- matters and the last-registered action should fire. -- -- == Example@@ -14,25 +14,25 @@ -- @ -- -- 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 :: (Debouncing 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 :: (Debouncing FilePath :> es) => FilePath -> FileEvent -> Eff es () -- onChange path event =---     debouncedWith 200 (<>) path [event] (rebuildWith path)+--     with 200 (<>) path [event] (rebuildWith path) -- @ module Atelier.Effects.Debounce     ( -- * Effect       Debounce-    , debouncedWith-    , debounced+    , with+    , withArg        -- * Interpreters-    , runDebounce-    , runDebounceNoOp+    , run+    , runNoOp        -- * Helpers     , ensureEntry@@ -42,11 +42,17 @@ where  import Data.Dynamic (Dynamic, fromDynamic, toDyn)-import Effectful (Effect, Limit (..), Persistence (..), UnliftStrategy (..))+import Effectful+    ( Dispatch (..)+    , DispatchOf+    , 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.Dispatch.Dynamic (interpretWith, localSeqUnlift, localUnlift, send)  import Effectful.Concurrent.STM qualified as STM import StmContainers.Map qualified as Map@@ -62,11 +68,7 @@ -- | 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+    WithArg         :: (Typeable arg)         => Millisecond         -> (arg -> arg -> arg)@@ -76,13 +78,23 @@         -> Debounce key m ()  -makeEffect ''Debounce+type instance DispatchOf (Debounce _) = 'Dynamic  +-- | 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.+withArg+    :: (Debounce key :> es, Typeable arg)+    => Millisecond -> (arg -> arg -> arg) -> key -> arg -> (arg -> Eff es a) -> Eff es ()+withArg settleWindow merge key arg callback = send $ WithArg settleWindow merge key arg callback++ -- | 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)+with :: (Debounce key :> es) => Millisecond -> key -> Eff es a -> Eff es ()+with settleMs key action = withArg settleMs (\_ _ -> ()) key () (\_ -> action)   -- | Per-key debounce state: the latest (merged) pending argument and a@@ -100,7 +112,7 @@ -- -- 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+run     :: forall key es a      . ( Conc :> es        , Concurrent :> es@@ -109,10 +121,10 @@        )     => Eff (Debounce key : es) a     -> Eff es a-runDebounce eff = do+run eff = do     state <- STM.atomically (Map.new @key @Entry)     interpretWith eff \env -> \case-        DebouncedWith settleMs merge key arg callback -> do+        WithArg settleMs merge key arg callback -> do             entry <- STM.atomically $ ensureEntry key arg state merge             localUnlift env (ConcUnlift Persistent (Limited 1)) \unlift ->                 void@@ -177,6 +189,6 @@  -- | 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)+runNoOp :: Eff (Debounce key : es) a -> Eff es a+runNoOp eff = interpretWith eff \env -> \case+    WithArg _ _ _ value callback -> localSeqUnlift env \unlift -> void $ unlift (callback value)

@@ -1,23 +1,9 @@--- | 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+    , runIO+    , runNoOp     ) where @@ -38,8 +24,7 @@   -- | 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.+-- execution, starting immediately. every :: (Delay :> es, TimeUnit t) => t -> Eff es () -> Eff es Void every delay action = forever do     action@@ -47,11 +32,11 @@   -- | Interpret 'Delay' using real thread delays.-runDelay :: (Concurrent :> es) => Eff (Delay : es) a -> Eff es a-runDelay = interpret_ \(Wait delay) ->+runIO :: (Concurrent :> es) => Eff (Delay : es) a -> Eff es a+runIO = 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 ()+-- | Delay interpreter that makes every 'wait' return immediately.+runNoOp :: Eff (Delay : es) a -> Eff es a+runNoOp = interpret_ \(Wait _) -> pure ()

@@ -1,19 +1,17 @@ -- | 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-    , lookupEnv-    , runEnv-    , runEnvConst+    , all+    , lookup+    , runIO+    , runConst     ) where  import Effectful (Effect, IOE) import Effectful.Dispatch.Dynamic (interpret_) import Effectful.TH (makeEffect)+import Prelude hiding (All (..), all)  import Data.List qualified as List import System.Environment qualified as System@@ -22,23 +20,23 @@ -- | 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)]+    All :: Env m [(String, String)]     -- | Pick out one value from the environment.-    LookupEnv :: String -> Env m (Maybe String)+    Lookup :: String -> Env m (Maybe String)   makeEffect ''Env   -- | Interpret 'Env' against the real process environment.-runEnv :: (IOE :> es) => Eff (Env : es) a -> Eff es a-runEnv = interpret_ $ \case-    GetEnvironment -> liftIO System.getEnvironment-    LookupEnv key -> liftIO $ System.lookupEnv key+runIO :: (IOE :> es) => Eff (Env : es) a -> Eff es a+runIO = interpret_ $ \case+    All -> liftIO System.getEnvironment+    Lookup key -> liftIO $ System.lookupEnv key  --- | Interpret 'Env' with a fixed environment, for tests.-runEnvConst :: [(String, String)] -> Eff (Env : es) a -> Eff es a-runEnvConst env = interpret_ $ \case-    GetEnvironment -> pure env-    LookupEnv key -> pure $ List.lookup key env+-- | Interpret 'Env' with a fixed environment.+runConst :: [(String, String)] -> Eff (Env : es) a -> Eff es a+runConst env = interpret_ $ \case+    All -> pure env+    Lookup key -> pure $ List.lookup key env

@@ -1,17 +1,14 @@ -- | 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+    , with+    , success+    , failure        -- * Interpreters-    , runExit-    , runExitNoOp+    , runIO+    , runNoOp     ) where @@ -27,30 +24,29 @@ -- | 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+    With :: ExitCode -> Exit m a   makeEffect ''Exit   -- | Exit the program successfully (exit code 0).-exitSuccess :: (Exit :> es) => Eff es a-exitSuccess = exitWith ExitSuccess+success :: (Exit :> es) => Eff es a+success = with ExitSuccess   -- | Exit the program with a generic failure (exit code 1).-exitFailure :: (Exit :> es) => Eff es a-exitFailure = exitWith (ExitFailure 1)+failure :: (Exit :> es) => Eff es a+failure = with (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)+runIO :: (IOE :> es) => Eff (Exit : es) a -> Eff es a+runIO = interpret_ \(With 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+runNoOp :: Eff (Exit : es) a -> Eff es (Either ExitCode a)+runNoOp =+    reinterpret_ (runErrorNoCallStack @ExitCode) \(With code) -> throwError code

@@ -0,0 +1,113 @@+{-# OPTIONS_GHC -Wno-redundant-constraints #-}++module Atelier.Effects.FSNotify+    ( FSNotify+    , withManager+    , startManager+    , stopManager+    , withManagerConf+    , startManagerConf+    , watchDir+    , watchDirChan+    , watchTree+    , watchTreeChan+    , module System.FSNotify+    , run+    )+where++import Effectful (Dispatch (..), DispatchOf, Effect, IOE, Limit (..), Persistence (..))+import Effectful.Dispatch.Static+    ( SideEffects (..)+    , StaticRep+    , concUnliftIO+    , evalStaticRep+    , unsafeEff+    , unsafeEff_+    )+import System.FSNotify hiding+    ( Action+    , startManager+    , startManagerConf+    , stopManager+    , watchDir+    , watchDirChan+    , watchTree+    , watchTreeChan+    , withManager+    , withManagerConf+    )++import System.FSNotify qualified as FSNotify+++data FSNotify :: Effect+++type instance DispatchOf FSNotify = Static 'WithSideEffects+++data instance StaticRep FSNotify = FSNotify+++type Action es = Event -> Eff es ()+++withManager :: (FSNotify :> es) => (WatchManager -> Eff es a) -> Eff es a+withManager act =+    unsafeEff \env ->+        concUnliftIO env Persistent Unlimited \unlift ->+            FSNotify.withManager (unlift . act)+++startManager :: (FSNotify :> es) => Eff es WatchManager+startManager = unsafeEff_ $ FSNotify.startManager+++stopManager :: (FSNotify :> es) => WatchManager -> Eff es ()+stopManager = unsafeEff_ . FSNotify.stopManager+++withManagerConf :: (FSNotify :> es) => WatchConfig -> (WatchManager -> Eff es a) -> Eff es a+withManagerConf conf act =+    unsafeEff \env ->+        concUnliftIO env Persistent Unlimited \unlift ->+            FSNotify.withManagerConf conf (unlift . act)+++startManagerConf :: (FSNotify :> es) => WatchConfig -> Eff es WatchManager+startManagerConf = unsafeEff_ . FSNotify.startManagerConf+++watchDir+    :: (FSNotify :> es) => WatchManager -> FilePath -> ActionPredicate -> Action es -> Eff es StopListening+watchDir watchManager filePath actionPredicate action =+    unsafeEff \env ->+        concUnliftIO env Persistent Unlimited \unlift ->+            FSNotify.watchDir watchManager filePath actionPredicate (unlift . action)+++watchDirChan+    :: (FSNotify :> es)+    => WatchManager -> FilePath -> ActionPredicate -> EventChannel -> Eff es StopListening+watchDirChan watchManager filePath actionPredicate eventChannel =+    unsafeEff_ $ FSNotify.watchDirChan watchManager filePath actionPredicate eventChannel+++watchTree+    :: (FSNotify :> es) => WatchManager -> FilePath -> ActionPredicate -> Action es -> Eff es StopListening+watchTree watchManager filePath actionPredicate action =+    unsafeEff \env ->+        concUnliftIO env Persistent Unlimited \unlift ->+            FSNotify.watchTree watchManager filePath actionPredicate (unlift . action)+++watchTreeChan+    :: (FSNotify :> es)+    => WatchManager -> FilePath -> ActionPredicate -> EventChannel -> Eff es StopListening+watchTreeChan watchManager filePath actionPredicate eventChannel =+    unsafeEff_ $ FSNotify.watchTreeChan watchManager filePath actionPredicate eventChannel+++run :: (IOE :> es) => Eff (FSNotify : es) a -> Eff es a+run = evalStaticRep FSNotify

@@ -0,0 +1,33 @@+{-# OPTIONS_GHC -Wno-redundant-constraints #-}++module Atelier.Effects.FSNotify.Devel+    ( treeExtAny+    , treeExtExists+    , module System.FSNotify.Devel+    )+where++import Effectful (Limit (..), Persistence (..))+import Effectful.Dispatch.Static (concUnliftIO, unsafeEff)+import System.FSNotify (StopListening, WatchManager)+import System.FSNotify.Devel hiding (treeExtAny, treeExtExists)++import System.FSNotify.Devel qualified as FSNotify.Devel++import Atelier.Effects.FSNotify (FSNotify)+++treeExtAny+    :: (FSNotify :> es)+    => WatchManager -> FilePath -> Text -> (FilePath -> Eff es ()) -> Eff es StopListening+treeExtAny manager path extension action = unsafeEff \env ->+    concUnliftIO env Persistent Unlimited \unlift ->+        FSNotify.Devel.treeExtAny manager path extension (\fp -> unlift $ action fp)+++treeExtExists+    :: (FSNotify :> es)+    => WatchManager -> FilePath -> Text -> (FilePath -> Eff es ()) -> Eff es StopListening+treeExtExists manager path extension action = unsafeEff \env ->+    concUnliftIO env Persistent Unlimited \unlift ->+        FSNotify.Devel.treeExtExists manager path extension (\fp -> unlift $ action fp)

@@ -1,17 +1,12 @@ {-# 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 (..)     , IOMode (..)-    , withFile+    , with     , hClose     , hFlush     , hGetLine@@ -21,7 +16,7 @@     , hPutLBsLn     , hIsEOF     , hSetBuffering-    , runFile+    , run     ) where @@ -52,8 +47,8 @@   -- | 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)+with :: (File :> es, HasCallStack) => FilePath -> IOMode -> (Handle -> Eff es a) -> Eff es a+with fp m f = unsafeSeqUnliftIO \unlift -> IO.withFile fp m (unlift . f)   -- | Lifted `System.IO.hClose`.@@ -103,5 +98,5 @@   -- | Run file operations.-runFile :: (HasCallStack, IOE :> es) => Eff (File : es) a -> Eff es a-runFile = evalStaticRep File+run :: (HasCallStack, IOE :> es) => Eff (File : es) a -> Eff es a+run = evalStaticRep File

@@ -22,9 +22,10 @@     , getModificationTime     , getCurrentDirectory     , getXdgRuntimeDir-    , runFileSystemIO-    , runFileSystemNoOp-    , runFileSystemState+    , makeAbsolute+    , runIO+    , runNoOp+    , runState     ) where @@ -83,6 +84,16 @@     GetXdgRuntimeDir :: FileSystem m FilePath     -- | Obtain the time at which the file or directory was last modified.     GetModificationTime :: FilePath -> FileSystem m UTCTime+    -- | Convert a path into an absolute path. If the given path is relative,+    -- the current directory is prepended and then the combined result is+    -- normalized. If the path is already absolute, the path is simply+    -- normalized. The function preserves the presence or absence of the+    -- trailing path separator unless the path refers to the root directory /.+    --+    -- If the path is already absolute, the operation never fails. Otherwise,+    -- the operation may fail with the same exceptions as+    -- 'getCurrentDirectory'.+    MakeAbsolute :: FilePath -> FileSystem m FilePath   makeEffect ''FileSystem@@ -110,8 +121,8 @@   -- | Interpret 'FileSystem' against the real filesystem.-runFileSystemIO :: (IOE :> es) => Eff (FileSystem : es) a -> Eff es a-runFileSystemIO = interpret_ $ \case+runIO :: (IOE :> es) => Eff (FileSystem : es) a -> Eff es a+runIO = interpret_ $ \case     ReadFileBs path -> liftIO $ BS.readFile path     ReadFileLbsFrom path offset ->         liftIO@@ -131,12 +142,13 @@     GetCurrentDirectory -> liftIO Dir.getCurrentDirectory     GetXdgRuntimeDir -> liftIO $ fromMaybe "/tmp" <$> lookupEnv "XDG_RUNTIME_DIR"     GetModificationTime path -> liftIO $ Dir.getModificationTime path+    MakeAbsolute path -> liftIO $ Dir.makeAbsolute path   -- | 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+runNoOp :: Eff (FileSystem : es) a -> Eff es a+runNoOp = interpret_ $ \case     ReadFileBs _ -> pure mempty     ReadFileLbsFrom _ _ -> pure mempty     DoesFileExist _ -> pure False@@ -151,15 +163,16 @@     GetCurrentDirectory -> pure "."     GetXdgRuntimeDir -> pure "/tmp"     GetModificationTime _ -> pure $ UTCTime (Day.fromOrdinalDate 1970 1) 0+    MakeAbsolute path -> pure path   -- | 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+runState     :: (State (Map FilePath ByteString) :> es)     => Eff (FileSystem : es) a -> Eff es a-runFileSystemState = interpret_ \case+runState = interpret_ \case     ReadFileBs fp ->         maybe (throwIO $ userError "No such file") pure             =<< gets (M.lookup fp)@@ -183,3 +196,4 @@     GetCurrentDirectory -> pure "/"     GetXdgRuntimeDir -> pure "/tmp"     GetModificationTime _ -> pure $ UTCTime (Day.fromOrdinalDate 1970 1) 0+    MakeAbsolute path -> pure path

@@ -37,30 +37,14 @@ -- 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+    ( -- * Effect+      FileWatcher     , watchFilePaths     , watchFilePathsDebounced        -- * Interpreters-    , runFileWatcherIO-    , runFileWatcherScripted+    , runIO+    , runScripted        -- * Internals (exported for testing)     , deduplicateDirs@@ -68,96 +52,34 @@     ) where -import Control.Concurrent (threadDelay) import Data.List (nub)-import Effectful (Effect, IOE)+import Effectful (Effect, Limit (..), Persistence (..), UnliftStrategy (..)) import Effectful.Concurrent (Concurrent)-import Effectful.Dispatch.Dynamic (interpretWith, localSeqUnlift, localUnliftIO, reinterpret)+import Effectful.Dispatch.Dynamic+    ( interpret+    , localSeqUnlift+    , localUnlift+    , 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 System.FSNotify (eventPath) -import Data.Text qualified as T import Effectful.Concurrent qualified as Concurrent-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))-+import Atelier.Effects.Debounce (Debounce)+import Atelier.Effects.Delay (Delay)+import Atelier.Effects.FSNotify (FSNotify)+import Atelier.Effects.FileSystem (FileSystem)+import Atelier.Effects.FileWatcher.Event (Event)+import Atelier.Effects.FileWatcher.Watch (Watch) --- | 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+import Atelier.Effects.Debounce qualified as Debounce+import Atelier.Effects.Delay qualified as Delay+import Atelier.Effects.FSNotify qualified as FSNotify+import Atelier.Effects.FileWatcher.Event qualified as Event+import Atelier.Effects.FileWatcher.Watch qualified as Watch+import Atelier.Time qualified as Time   data FileWatcher :: Effect where@@ -166,7 +88,7 @@     -- 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+    WatchFilePaths :: [Watch] -> (FilePath -> Event -> m a) -> FileWatcher m Void   makeEffect ''FileWatcher@@ -178,55 +100,49 @@ watchFilePathsDebounced     :: (Debounce FilePath :> es, FileWatcher :> es)     => [Watch]-    -> (FilePath -> FileEvent -> Eff es ())+    -> (FilePath -> Event -> Eff es ())     -> Eff es Void watchFilePathsDebounced watches callback =     watchFilePaths watches \path event ->-        debouncedWith 100 mergeFileEvent path event (callback path)+        Debounce.withArg 100 (<>) 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]+runIO :: (Delay :> es, FSNotify :> es, FileSystem :> es) => Eff (FileWatcher : es) a -> Eff es a+runIO = interpret \env -> \case+    WatchFilePaths watches callback -> do+        absWatches <- forM watches Watch.makeAbsolute+        FSNotify.withManager \mgr -> do+            let dedupedDirs = deduplicateDirs $ Watch.path <$> absWatches+            localUnlift env (ConcUnlift Persistent Unlimited) \unlift ->                 for_ dedupedDirs \d ->-                    watchTree mgr d (matchesAny absWatches . eventPath) \fsEvent ->-                        void $ unliftIO $ callback (eventPath fsEvent) (toFileEvent fsEvent)-                -- Park indefinitely to hold the manager open. fsnotify delivers-                -- events on its own threads, so there is nothing to do here, and-                -- waking up is not free: each wake-up ends the RTS idle period-                -- and re-arms idle GC, costing a full major collection. 'forever'-                -- is belt-and-braces in case the delay ever returns early.-                ---                -- Preferred over @atomically retry@: a transaction that retries-                -- without having read a 'TVar' has no wakeup path, so it stays-                -- parked only for as long as GC still sees this thread as-                -- reachable. Should it ever become unreachable the RTS throws-                -- @BlockedIndefinitelyOnSTM@, which would unwind 'withManager'-                -- and silently stop all watching. A delay carries no such-                -- dependency on how callers happen to retain the thread.-                forever $ threadDelay maxBound+                    FSNotify.watchTree mgr d (matchesAny absWatches . eventPath) \fsEvent ->+                        void $ unlift $ callback (eventPath fsEvent) (Event.fromFS fsEvent)+            -- Park indefinitely to hold the manager open. fsnotify delivers+            -- events on its own threads, so there is nothing to do here, and+            -- waking up is not free: each wake-up ends the RTS idle period+            -- and re-arms idle GC, costing a full major collection. 'forever'+            -- is belt-and-braces in case the delay ever returns early.+            forever+                $ Delay.wait @Time.Microsecond+                $ Time.fromMicroseconds+                $ fromIntegral (maxBound :: Int)   -- | Scripted interpreter for testing. -- -- Delivers all scripted events to the callback in order, then parks forever,--- matching the blocking semantics of 'runFileWatcherIO' — 'WatchFilePaths'--- returns 'Void', so callers must never be resumed. Parks with a delay rather--- than @atomically retry@ for the same reason as 'runFileWatcherIO': a retry--- that read no 'TVar' stays parked only while GC sees the thread as reachable,--- so whether it survives depends on whether the test happens to hold onto the+-- matching the blocking semantics of 'runIO' — 'WatchFilePaths' returns+-- 'Void', so callers must never be resumed. Parks with a delay rather than+-- @atomically retry@ for the same reason as 'runIO': a retry that+-- read no 'TVar' stays parked only while GC sees the thread as reachable, so+-- whether it survives depends on whether the test happens to hold onto the -- 'ThreadId'. -- -- 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+runScripted+    :: (Concurrent :> es) => [(FilePath, Event)] -> Eff (FileWatcher : es) a -> Eff es a+runScripted events = reinterpret (evalState events) \env -> \case     WatchFilePaths _ callback ->         localSeqUnlift env \unlift -> do             events' <- get@@ -237,32 +153,13 @@  -- 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+    notRedundant d = not $ any (\d' -> d' /= d && Watch.isStrictAncestor d' d) dirs   -- | 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+matchesAny watches path = any (Watch.matches path) watches

@@ -0,0 +1,49 @@+module Atelier.Effects.FileWatcher.Event+    ( Event (..)+    , merge+    , fromFS+    )+where++import System.FSNotify qualified as FSN+++-- | The kind of filesystem change that triggered a watch callback.+data Event+    = -- | A new file was created.+      Added+    | -- | An existing file was modified.+      Modified+    | -- | A file was deleted.+      Removed+    deriving stock (Eq, Show)+++instance Semigroup Event where+    (<>) = merge+++-- | Merge two 'Event'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.+merge :: Event -> Event -> Event+merge _ Removed = Removed+merge Removed Added = Added+merge Added _ = Added+merge _ event = event+++fromFS :: FSN.Event -> Event+fromFS = \case+    FSN.Added {} -> Added+    FSN.Modified {} -> Modified+    FSN.ModifiedAttributes {} -> Modified+    FSN.CloseWrite {} -> Modified+    FSN.Removed {} -> Removed+    FSN.WatchedDirectoryRemoved {} -> Removed+    FSN.Unknown {} -> Modified

@@ -0,0 +1,95 @@+module Atelier.Effects.FileWatcher.Watch+    ( -- * Watch specification+      Watch+    , path++      -- ** Constructors+    , dir+    , dirExt+    , dirWhere++      -- ** Combinators+    , excluding+    , containing++      -- ** Check+    , matches++      -- ** Utils+    , isStrictAncestor+    , makeAbsolute+    )+where++import Data.Text qualified as T+import System.FilePath qualified as Path++import Atelier.Effects.FileSystem (FileSystem)++import Atelier.Effects.FileSystem qualified as FileSystem+++-- | Specification of a directory to watch recursively, with a file predicate.+data Watch = Watch FilePath (FilePath -> Bool)+++path :: Watch -> FilePath+path (Watch p _) = p+++-- | 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 (Path.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+++matches :: FilePath -> Watch -> Bool+matches filePath (Watch d predicate) =+    (d == filePath || isStrictAncestor d filePath) && predicate filePath+++-- | @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+++makeAbsolute :: (FileSystem :> es) => Watch -> Eff es Watch+makeAbsolute (Watch p predicate) = flip Watch predicate <$> FileSystem.makeAbsolute p

@@ -0,0 +1,38 @@+-- | An effect for generating UUIDs.+module Atelier.Effects.GenUUID+    ( GenUUID+    , UUID+    , gen+    , runIO+    , runConst+    )+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.+--+-- Produces fresh random (version 4) UUIDs.+runIO :: (IOE :> es) => Eff (GenUUID : es) a -> Eff es a+runIO = interpret_ \Gen -> liftIO nextRandom+++-- | Interpret 'GenUUID' so 'gen' always returns the given fixed UUID, for tests.+--+-- Returns a fixed UUID every time, for deterministic tests.+runConst :: UUID -> Eff (GenUUID : es) a -> Eff es a+runConst uuid = interpret_ \Gen -> pure uuid

@@ -1,8 +1,4 @@ -- | 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@@ -10,8 +6,6 @@     , withConst     , toReader     , fromState-    , runInputEff-    , runInputConst     , map     ) where@@ -28,12 +22,11 @@  -- | 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+-- 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 '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@@ -47,12 +40,6 @@   -- | Runs the passed effectful action every time 'input' is invoked.-runInputEff :: Eff es i -> Eff (Input i : es) a -> Eff es a-runInputEff = withEff-{-# DEPRECATED runInputEff "Use 'Atelier.Effects.Input.withEff' instead." #-}----- | Runs the passed effectful action every time 'input' is invoked. withEff :: Eff es i -> Eff (Input i : es) a -> Eff es a withEff mk = interpret_ \Input -> mk @@ -60,16 +47,8 @@ -- | 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 = withConst-{-# DEPRECATED runInputConst "Use 'Atelier.Effects.Input.withConst' instead." #-}----- | Provides the same value for every invocation of the 'input' operation.--- This is equivalent to using 'Effectful.Reader.Static' or--- 'Effectful.Reader.Local', but is available here for testing. withConst :: i -> Eff (Input i : es) a -> Eff es a-withConst = runInputEff . pure+withConst = withEff . pure   -- | Retrieves the value once, and exposes it as a 'Reader' effect.

@@ -217,9 +217,9 @@     -> 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+    (inChan, outChan) <- Chan.new @a+    let yielder = interpretWith_ yields \(Yield x) -> Chan.write inChan x+        awaiter = interpretWith_ awaits \Await -> Chan.read outChan     -- Ensure the awaiter runs first.     awaitThread <- Conc.fork awaiter     yieldThread <- Conc.fork yielder

@@ -47,9 +47,9 @@     => (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)+    (inChan, outChan) <- Chan.new+    Sub.forkListener_ (Chan.write inChan)+    use $ Iterator (Chan.read outChan)   -- | Iterate only over values that pass a predicate.

@@ -37,10 +37,10 @@     , withNamespace        -- * Interpreters-    , runLog-    , runLogNoOp-    , runLogToHandle-    , runLogWriter+    , runIO+    , runNoOp+    , runToHandle+    , runWriter        -- * Utils     , minimumSeverityFromEnv@@ -49,9 +49,9 @@  import Data.Aeson (FromJSON (..), ToJSON) import Data.Default (Default (..))-import Data.List (lookup) import Effectful (Effect, IOE) import Effectful.Dispatch.Dynamic (localSeqUnlift, reinterpret, reinterpretWith)+import Effectful.NonDet (OnEmptyPolicy (..), emptyEff, runNonDet) import Effectful.Reader.Static (Reader, ask, local, runReader) import Effectful.TH (makeEffect) import Effectful.Writer.Static.Shared (Writer, tell)@@ -59,12 +59,14 @@  import Data.ByteString.Char8 qualified as B8 -import Atelier.Effects.Env (Env, getEnvironment)+import Atelier.Effects.Env (Env) import Atelier.Types.JSON.QuietSnake (QuietSnake (..)) import Atelier.Types.JSON.ReadShow (ReadShow (..))-import Atelier.Types.WithDefaults (WithDefaults (..))+import Atelier.Types.JSON.WithDefaults (WithDefaults (..)) +import Atelier.Effects.Env qualified as Env + -- | Effect for structured logging with hierarchical namespaces. data Log :: Effect where     -- | Emit a fully-formed log 'Message'.@@ -171,8 +173,8 @@   -- | Consumes `Log` effects, and discards the logged messages-runLogNoOp :: Eff (Log : es) a -> Eff es a-runLogNoOp = reinterpret (runReader (Namespace "")) $ \env -> \case+runNoOp :: Eff (Log : es) a -> Eff es a+runNoOp = reinterpret (runReader (Namespace "")) $ \env -> \case     LogMsg _ -> pure ()     WithNamespace ns act -> localSeqUnlift env $ \unlift ->         local (<> ns) $ unlift act@@ -184,8 +186,8 @@ -- 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+runIO :: (Env :> es, IOE :> es, Reader Config :> es) => Eff (Log : es) a -> Eff es a+runIO action = do     config <- ask     severity <- fromMaybe config.minimumSeverity <$> minimumSeverityFromEnv @@ -208,8 +210,8 @@  -- | 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 =+runToHandle :: (IOE :> es) => Handle -> Severity -> Eff (Log : es) a -> Eff es a+runToHandle handle minSeverity action =     reinterpretWith (runReader (Namespace "")) action \env -> \case         LogMsg msg ->             liftIO $ when (msg.severity >= minSeverity) do@@ -221,8 +223,8 @@   -- | 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+runWriter :: (Writer [Message] :> es) => Eff (Log : es) a -> Eff es a+runWriter = reinterpret (runReader (Namespace "")) $ \env -> \case     LogMsg msg -> tell [msg]     WithNamespace ns act -> localSeqUnlift env $ \unlift ->         local (<> ns) $ unlift act@@ -244,11 +246,22 @@  minimumSeverityFromEnv :: (Env :> es) => Eff es (Maybe Severity) minimumSeverityFromEnv = do-    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-    pure $ overrideDebug <|> overrideLogging <|> overrideLog+    fmap rightToMaybe+        $ runNonDet OnEmptyKeep+        $ asum+            [ Env.lookup "LOG" >>= readAlt+            , Env.lookup "LOGGING" >>= readAlt+            , Env.lookup "DEBUG" >>= \case+                Nothing -> emptyEff+                Just x+                    | x == "0" -> emptyEff+                    | otherwise -> pure DEBUG+            ]+  where+    readAlt Nothing = emptyEff+    readAlt (Just x) = case readMaybe x of+        Nothing -> emptyEff+        Just x' -> pure x'   square :: Text -> Text

@@ -1,54 +1,70 @@ -- | 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.+-- Backed by the @daemons@ package. module Atelier.Effects.Posix.Daemons     ( Daemons     , PidFile (..)     , daemonize     , isRunning     , forceKillAndWait-    , runDaemons+    , run     ) where  import Data.Default (def)-import Effectful (Effect, IOE, Limit (..), Persistence (..), UnliftStrategy (..))-import Effectful.Dispatch.Dynamic (interpretWith, localUnliftIO)+import Effectful (Dispatch (..), DispatchOf, Effect, IOE, Limit (..), Persistence (..))+import Effectful.Dispatch.Static+    ( SideEffects (..)+    , StaticRep+    , concUnliftIO+    , evalStaticRep+    , getStaticRep+    , unsafeEff+    , unsafeEff_+    ) 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 ())+data Daemons :: Effect  +type instance DispatchOf Daemons = Static 'WithSideEffects+++data instance StaticRep Daemons = Daemons++ -- | The path to a daemon's PID file, used to track and control it. newtype PidFile = PidFile {getPidFile :: FilePath}  -makeEffect ''Daemons+-- | Daemonize the given program, ensuring it is cleanly separated from the+-- spawning process.+daemonize :: (Daemons :> es) => PidFile -> Eff es () -> Eff es ()+daemonize (PidFile pidFile) program = do+    Daemons <- getStaticRep+    unsafeEff \env ->+        concUnliftIO env Persistent Unlimited \unlift -> do+            Daemons.runDetached (Just pidFile) def+                $ unlift program  --- | 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+-- | Check whether a daemon is running for the provided PID file.+isRunning :: (Daemons :> es) => PidFile -> Eff es Bool+isRunning (PidFile pidFile) = do+    Daemons <- getStaticRep+    unsafeEff_ $ Daemons.isRunning pidFile+++-- | Kill the daemon associated with the provided PID file using `SIGKILL`.+forceKillAndWait :: (Daemons :> es) => PidFile -> Eff es (Either SomeException ())+forceKillAndWait (PidFile pidFile) = do+    Daemons <- getStaticRep+    trySync $ unsafeEff_ $ Daemons.brutalKill pidFile+++run :: (IOE :> es) => Eff (Daemons : es) a -> Eff es a+run = evalStaticRep Daemons

@@ -1,3 +1,5 @@+{-# OPTIONS_GHC -Wno-redundant-constraints #-}+ -- | Effect for spawning and interacting with external processes. -- -- Unifies @typed-process@ (configuration, lifecycle and stream capture) and the@@ -38,15 +40,14 @@     , getExecutablePath        -- * Interpreters-    , runProcessIO+    , run     ) where  import Control.Exception (IOException, catch)-import Effectful (Effect, IOE)-import Effectful.Dispatch.Dynamic (interpret_)+import Effectful (Dispatch (..), DispatchOf, Effect, IOE)+import Effectful.Dispatch.Static (SideEffects (..), StaticRep, evalStaticRep, unsafeEff_) import Effectful.Exception (bracket, trySync)-import Effectful.TH (makeEffect) import System.Exit (ExitCode (..)) import System.Posix.Signals (sigTERM, signalProcessGroup) import System.Process (Pid, getPid, interruptProcessGroupOf)@@ -83,36 +84,15 @@ getStderr (RunningProcess p) = TP.getStderr p  -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)-    -- | Run a process to completion, capturing both stdout and stderr along with-    -- its exit code.-    ReadProcess :: ProcessConfig i o e -> Process m (ExitCode, LByteString, LByteString)-    -- | Run a process to completion, returning only its exit code. Unlike-    -- 'ReadProcessStdout' this does not capture stdout.-    RunProcess :: ProcessConfig i o e -> Process m ExitCode-    -- | The absolute path of the currently running executable, for re-invoking-    -- this program as a subprocess.-    GetExecutablePath :: Process m FilePath-    -- | Spawn a process and return its handle. Internal; callers use 'withProcessGroup'.-    StartProcess :: ProcessConfig i o e -> Process m (RunningProcess i o e)-    -- | Terminate the leader and close its streams. Internal; does not reach the-    -- rest of the group.-    StopProcess :: RunningProcess i o e -> Process m ()-    -- | Block until the process exits and return its exit code.-    WaitExitCode :: RunningProcess i o e -> Process m ExitCode-    -- | Send SIGINT to the process's group. Requires @'setCreateGroup' True@.-    InterruptProcessGroup :: RunningProcess i o e -> Process m ()-    -- | Look up the OS process id, or 'Nothing' if it has already exited. Internal.-    GetProcessId :: RunningProcess i o e -> Process m (Maybe Pid)-    -- | Send SIGTERM to the given process group. Internal.-    SignalProcessGroupTerm :: Pid -> Process m ()+data Process :: Effect  -makeEffect ''Process+type instance DispatchOf Process = Static 'WithSideEffects  +data instance StaticRep Process = Process++ -- | Run a process in its own process group, terminating the /whole group/ — the -- process and every descendant it spawned — when the body returns or throws. --@@ -159,16 +139,58 @@         _ -> Nothing  -runProcessIO :: (IOE :> es) => Eff (Process : es) a -> Eff es a-runProcessIO = interpret_ \case-    ReadProcessStdout cfg -> liftIO $ TP.readProcessStdout cfg-    ReadProcess cfg -> liftIO $ TP.readProcess cfg-    RunProcess cfg -> liftIO $ TP.runProcess cfg-    GetExecutablePath -> liftIO Env.getExecutablePath-    StartProcess cfg -> liftIO $ RunningProcess <$> TP.startProcess cfg-    StopProcess (RunningProcess p) -> liftIO $ TP.stopProcess p-    WaitExitCode (RunningProcess p) -> liftIO $ TP.waitExitCode p-    InterruptProcessGroup (RunningProcess p) -> liftIO $ interruptProcessGroupOf (TP.unsafeProcessHandle p)-    GetProcessId (RunningProcess p) -> liftIO $ getPid (TP.unsafeProcessHandle p)-    SignalProcessGroupTerm pid ->-        liftIO $ signalProcessGroup sigTERM pid `catch` \(_ :: IOException) -> pure ()+-- | Run a process to completion, returning its exit code and captured stdout.+readProcessStdout :: (Process :> es) => ProcessConfig i o e -> Eff es (ExitCode, LByteString)+readProcessStdout = unsafeEff_ . TP.readProcessStdout+++-- | Run a process to completion, capturing both stdout and stderr along with+-- its exit code.+readProcess :: (Process :> es) => ProcessConfig i o e -> Eff es (ExitCode, LByteString, LByteString)+readProcess = unsafeEff_ . TP.readProcess+++runProcess :: (Process :> es) => ProcessConfig i o e -> Eff es ExitCode+runProcess = unsafeEff_ . TP.runProcess+++-- | The absolute path of the currently running executable, for re-invoking+-- this program as a subprocess.+getExecutablePath :: (Process :> es) => Eff es FilePath+getExecutablePath = unsafeEff_ Env.getExecutablePath+++-- | Spawn a process and return its handle. Internal; callers use 'withProcessGroup'.+startProcess :: (Process :> es) => ProcessConfig i o e -> Eff es (RunningProcess i o e)+startProcess = unsafeEff_ . fmap RunningProcess . TP.startProcess+++-- | Terminate the leader and close its streams. Internal; does not reach the+-- rest of the group.+stopProcess :: (Process :> es) => RunningProcess i o e -> Eff es ()+stopProcess = unsafeEff_ . TP.stopProcess . getRunningProcess+++-- | Block until the process exits and return its exit code.+waitExitCode :: (Process :> es) => RunningProcess i o e -> Eff es ExitCode+waitExitCode = unsafeEff_ . TP.waitExitCode . getRunningProcess+++-- | Send SIGINT to the process's group. Requires @'setCreateGroup' True@.+interruptProcessGroup :: (Process :> es) => RunningProcess i o e -> Eff es ()+interruptProcessGroup = unsafeEff_ . interruptProcessGroupOf . TP.unsafeProcessHandle . getRunningProcess+++-- | Look up the OS process id, or 'Nothing' if it has already exited. Internal.+getProcessId :: (Process :> es) => RunningProcess i o e -> Eff es (Maybe Pid)+getProcessId = unsafeEff_ . getPid . TP.unsafeProcessHandle . getRunningProcess+++-- | Send SIGTERM to the given process group. Internal.+signalProcessGroupTerm :: (Process :> es) => Pid -> Eff es ()+signalProcessGroupTerm pid =+    unsafeEff_ $ signalProcessGroup sigTERM pid `catch` \(_ :: IOException) -> pure ()+++run :: (IOE :> es) => Eff (Process : es) a -> Eff es a+run = evalStaticRep Process

@@ -13,4 +13,4 @@  -- | A process run in its own group by 'Atelier.Effects.Process.withProcessGroup'. -- Parameterised by its stdin, stdout and stderr stream types.-newtype RunningProcess i o e = RunningProcess (TP.Process i o e)+newtype RunningProcess i o e = RunningProcess {getRunningProcess :: TP.Process i o e}

@@ -19,18 +19,18 @@      . (Chan :> es, Clock :> es)     => Eff (Pub event : Sub event : es) a -> Eff es a run action = do-    (inChan, _) <- Chan.newChan @(UTCTime, event)+    (inChan, _) <- Chan.new @(UTCTime, event)     let handlePub = interpret_ \case             Publish event -> do                 timestamp <- Clock.currentTime-                Chan.writeChan inChan (timestamp, event)+                Chan.write inChan (timestamp, event)          handleSub = interpret \env -> \case             ListenWith onSubscribed listener -> localSeqUnlift env \unlift -> do-                chan <- Chan.dupChan inChan+                chan <- Chan.dup inChan                 unlift onSubscribed                 forever do-                    (timestamp, event) <- Chan.readChan chan+                    (timestamp, event) <- Chan.read chan                     unlift $ listener timestamp event      handleSub . handlePub $ action

@@ -4,7 +4,7 @@     , publish        -- * Interpeters-    , runNoOp+    , noOp     , toWriter     , map     , mapM@@ -28,8 +28,8 @@ makeEffect ''Pub  -runNoOp :: forall event es a. Eff (Pub event : es) a -> Eff es a-runNoOp = interpret_ \(Publish _) -> pure ()+noOp :: forall event es a. Eff (Pub event : es) a -> Eff es a+noOp = interpret_ \(Publish _) -> pure ()   -- | Handler that uses a provided Writer effect instead of actually publishing.

@@ -152,4 +152,6 @@ data OnceEx ev = OnceEx ev  -instance Show (OnceEx ev) where show _ = "OnceEx"+instance Show (OnceEx ev) where+    show :: OnceEx ev -> String+    show _ = "OnceEx"

@@ -1,18 +0,0 @@-module Atelier.Effects.Publishing (runPubSub) where--import Atelier.Effects.Chan (Chan)-import Atelier.Effects.Clock (Clock)-import Atelier.Effects.PubSub.Pub (Pub)-import Atelier.Effects.PubSub.Sub (Sub)--import Atelier.Effects.PubSub qualified as PubSub----- | Runs 'Pub' and 'Sub' effects with an internal channel for a specific event--- type.-runPubSub-    :: forall event es a-     . (Chan :> es, Clock :> es)-    => Eff (Pub event : Sub event : es) a -> Eff es a-runPubSub = PubSub.run-{-# DEPRECATED runPubSub "Use 'Atelier.Effects.PubSub.run' instead." #-}

@@ -1,8 +0,0 @@-module Atelier.Effects.Publishing.Pub-    {-# DEPRECATED "Use 'Atelier.Effects.PubSub.Pub' instead." #-}-    ( module Pub-    )-where--import Atelier.Effects.PubSub.Pub as Pub-

@@ -1,8 +0,0 @@-module Atelier.Effects.Publishing.Sub-    {-# DEPRECATED "Use 'Atelier.Effects.PubSub.Sub' instead." #-}-    ( module Sub-    )-where--import Atelier.Effects.PubSub.Sub as Sub-

@@ -1,38 +1,12 @@ -- | 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+    , count        -- * Interpreters-    , runTally-    , runTallyConst+    , run+    , runConst     ) where @@ -42,30 +16,43 @@ 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) +import Atelier.Effects.Cache qualified as Cache + -- | 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.+    -- | Increment the hit count for a key and run an action with said count.     ---    -- The classifier receives the new count and produces a status value of any-    -- type the caller chooses. The continuation then receives that status.-    WithTallyCheck+    -- @+    -- checkDuplicate :: (Tally DuplicateKey :> es) => DuplicateKey -> Config -> Eff es ()+    -- checkDuplicate key cfg =+    --     withTallyCheck key $ action . classify+    --   where+    --     action = \case+    --         Nothing      -> pure ()+    --         Just Minor   -> warnAboutPeer+    --         Just Critical -> banPeer+    --     classify c+    --         | c > cfg.criticalThreshold = Just Critical+    --         | c > cfg.warningThreshold  = Just Minor+    --         | otherwise                 = Nothing+    -- @+    Count         :: (Hashable key, Ord key)-        => key -> (Int -> status) -> (status -> m a) -> Tally key m a+        => key -> (Int -> m a) -> Tally key m a   makeEffect ''Tally   -- | Run the Tally effect, using a TTL-evicting cache as the backing store-runTally+run     :: forall key es a      . ( Clock :> es        , Conc :> es@@ -77,15 +64,15 @@        )     => 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)+run = reinterpret (Cache.runTTL @key @Int) $ \env -> \case+    Count key continuation -> localSeqUnlift env $ \unlift -> do+        c <- Cache.modify key (maybe 1 (+ 1))+        unlift $ continuation c   -- | 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)+runConst :: Int -> Eff (Tally key : es) a -> Eff es a+runConst c = interpret \env -> \case+    Count _ f -> localSeqUnlift env \unlift -> unlift $ f c

@@ -1,27 +1,28 @@ -- | 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+    , with+    , with_+    , run     ) where -import Effectful (Effect, IOE, Limit (..), Persistence (..), UnliftStrategy (..))-import Effectful.Dispatch.Dynamic (interpret, localUnliftIO)-import Effectful.TH (makeEffect)+import Effectful+    ( Dispatch (..)+    , DispatchOf+    , Effect+    , IOE+    , Limit (..)+    , Persistence (..)+    )+import Effectful.Dispatch.Static+    ( SideEffects (..)+    , StaticRep+    , concUnliftIO+    , evalStaticRep+    , getStaticRep+    , unsafeEff+    )  import System.Timeout qualified as IO @@ -29,25 +30,44 @@   -- | 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)+data Timeout :: Effect  -makeEffect ''Timeout+type instance DispatchOf Timeout = Static 'WithSideEffects  +data instance StaticRep Timeout = Timeout+++-- | Run an action, returning 'Just' its result if it completes within the+-- duration, or 'Nothing' if the deadline passes first.+--+-- '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.with (5 :: Second) fetchRemote+-- case result of+--     Just value -> use value+--     Nothing    -> logWarn \"fetch timed out\"+-- @+with :: (TimeUnit t, Timeout :> es) => t -> Eff es a -> Eff es (Maybe a)+with delay action = do+    Timeout <- getStaticRep+    unsafeEff \env -> do+        concUnliftIO env Persistent (Limited 1) \unlift ->+            IO.timeout (fromIntegral $ toMicroseconds delay) $ unlift action++ -- | 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+with_ :: (TimeUnit t, Timeout :> es) => t -> Eff es a -> Eff es ()+with_ t m = const () <$> with 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+run :: (HasCallStack, IOE :> es) => Eff (Timeout : es) a -> Eff es a+run = evalStaticRep Timeout

@@ -1,38 +0,0 @@--- | 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

@@ -1,33 +0,0 @@--- | 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)

@@ -0,0 +1,33 @@+-- | 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.JSON.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)

@@ -0,0 +1,23 @@+module Atelier.Types.JSON.Renamed (Renamed) where++import Data.Aeson (FromJSON (..), ToJSON (..))+import GHC.TypeLits (KnownSymbol, Symbol, symbolVal)+++data Renamed (from :: Symbol) (to :: Symbol)+    deriving stock (Eq, Generic, Show)+++instance ToJSON (Renamed from to) where+    toJSON = \case {}+    toEncoding = \case {}+++instance forall from to. (KnownSymbol from, KnownSymbol to) => FromJSON (Renamed from to) where+    parseJSON _ =+        fail+            $ "The property '"+                <> symbolVal (Proxy @from)+                <> "' has been renamed or moved to '"+                <> symbolVal (Proxy @to)+                <> "'"

@@ -0,0 +1,40 @@+-- | 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.JSON.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

@@ -1,12 +0,0 @@-module Atelier.Types.JsonReadShow-    {-# DEPRECATED "Use Atelier.Types.JSON.ReadShow instead" #-}-    (JsonReadShow (..))-where--import Data.Aeson (FromJSON, ToJSON)--import Atelier.Types.JSON.ReadShow (ReadShow (..))---newtype JsonReadShow a = JsonReadShow {getJsonReadShow :: a}-    deriving (FromJSON, ToJSON) via ReadShow a

@@ -1,8 +0,0 @@-module Atelier.Types.QuietSnake-    {-# DEPRECATED "Renamed to Atelier.Types.JSON.QuietSnake" #-}-    ( QuietSnake (..)-    )-where--import Atelier.Types.JSON.QuietSnake (QuietSnake (..))-

@@ -1,40 +0,0 @@--- | 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

@@ -11,7 +11,7 @@  import Atelier.Config (LoadedConfig (..), extractNestedConfig) import Atelier.Types.JSON.QuietSnake (QuietSnake (..))-import Atelier.Types.WithDefaults (WithDefaults (..))+import Atelier.Types.JSON.WithDefaults (WithDefaults (..))   test_Config :: TestTree

@@ -0,0 +1,66 @@+module Unit.Atelier.Effects.Arguments.SwitchSpec (test_Switch) where++import Options.Applicative+    ( Parser+    , ParserResult (..)+    , defaultPrefs+    , execParserPure+    , help+    , helper+    , info+    , long+    , renderFailure+    , short+    )+import Test.Tasty (TestTree, testGroup)+import Test.Tasty.HUnit (assertFailure, testCase, (@?=))++import Data.List qualified as List++import Atelier.Effects.Arguments.Switch qualified as Switch+++useCurrent :: Parser Bool+useCurrent = Switch.parser (long "use-current" <> short 'c' <> help "Use the current status.")+++parse :: [String] -> Maybe Bool+parse args = case execParserPure defaultPrefs (info useCurrent mempty) args of+    Success b -> Just b+    _ -> Nothing+++helpText :: IO String+helpText = case execParserPure defaultPrefs (info (useCurrent <**> helper) mempty) ["--help"] of+    Failure failure -> pure $ fst $ renderFailure failure "prog"+    _ -> assertFailure "expected --help to produce help text"+++test_Switch :: TestTree+test_Switch =+    testGroup+        "Switch"+        [ testCase "defaults to False" do+            parse [] @?= Just False+        , testCase "--<name> enables" do+            parse ["--use-current"] @?= Just True+        , testCase "short name enables" do+            parse ["-c"] @?= Just True+        , testCase "--no-<name> disables" do+            parse ["--no-use-current"] @?= Just False+        , testCase "last flag wins when enabling" do+            parse ["--no-use-current", "--use-current"] @?= Just True+        , testCase "last flag wins when disabling" do+            parse ["-c", "--no-use-current"] @?= Just False+        , testCase "last flag wins across many flags" do+            parse ["--use-current", "--no-use-current", "-c", "--no-use-current"] @?= Just False+        , testCase "help shows the combined flag" do+            text <- helpText+            List.lines text+                @?= [ "Usage: prog [-c,--[no-]use-current]"+                    , ""+                    , "Available options:"+                    , "  -c,--[no-]use-current    Use the current status."+                    , "  -h,--help                Show this help text"+                    ]+        ]

@@ -10,10 +10,9 @@ import Data.List qualified as List 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.Chan qualified as Chan+import Atelier.Effects.Conc qualified as Conc import Atelier.Effects.Yield qualified as Yield  @@ -101,7 +100,7 @@         ]     ]   where-    runTest = runEff . runConcurrent . runConc . runChan . runWriter+    runTest = runEff . runConcurrent . Conc.runIO . Chan.run . 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.

@@ -8,9 +8,14 @@ import Test.Tasty (TestTree, testGroup) import Test.Tasty.HUnit (testCase, (@?=)) -import Atelier.Effects.Cache.Singleflight (Singleflight, runSingleflight, updateCache, withCache)-import Atelier.Effects.Conc (Conc, runConc)-import Atelier.Effects.Delay (Delay, runDelay)+import Atelier.Effects.Cache.Singleflight+    ( Singleflight+    , runIO+    , update+    , with+    )+import Atelier.Effects.Conc (Conc)+import Atelier.Effects.Delay (Delay) import Atelier.Time (Millisecond) import Atelier.Types.Semaphore (Semaphore) @@ -32,10 +37,10 @@ runSingleflightTest action =     runEff         . runConcurrent-        . runConc-        . runDelay+        . Conc.runIO+        . Delay.runIO         . runState @Int 0-        . runSingleflight @Int @Int+        . runIO @Int @Int         $ action  @@ -64,7 +69,7 @@                 "First request executes computation"                 [ testCase "executes the computation on first request" $ do                     (result, execCount) <- runSingleflightTest $ do-                        withCache 1 (compute 42)+                        with 1 (compute 42)                     result @?= 42                     execCount @?= 1                 ]@@ -72,16 +77,16 @@                 "Cached value returned on second request"                 [ testCase "returns cached value without re-executing" $ do                     (result, execCount) <- runSingleflightTest $ do-                        r1 <- withCache 1 (compute 42)-                        r2 <- withCache 1 (compute 42)+                        r1 <- with 1 (compute 42)+                        r2 <- with 1 (compute 42)                         pure (r1, r2)                     result @?= (42, 42)                     execCount @?= 1                 , testCase "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)+                        r1 <- with 1 (compute 42)+                        r2 <- with 1 (compute 42)+                        r3 <- with 1 (compute 42)                         pure [r1, r2, r3]                     results @?= [42, 42, 42]                     execCount @?= 1@@ -93,7 +98,7 @@                         -- Launch 10 concurrent requests for the same key                         asyncs <- replicateM 10 do                             sem <- Sem.new-                            async <- Conc.fork $ withCache 1 (slowCompute sem 42)+                            async <- Conc.fork $ with 1 (slowCompute sem 42)                             pure (sem, async)                         traverse_ Sem.set $ fst <$> asyncs                         traverse Conc.await $ snd <$> asyncs@@ -104,10 +109,10 @@                     (results, execCount) <- runSingleflightTest $ do                         sem <- Sem.new                         -- Launch concurrent requests with different delays-                        a1 <- Conc.fork $ withCache 1 (slowCompute sem 99)+                        a1 <- Conc.fork $ with 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)+                        a2 <- Conc.fork $ with 1 (compute 99)+                        a3 <- Conc.fork $ with 1 (compute 99)                         Sem.signal sem -- Let first request continue                         r1 <- Conc.await a1                         r2 <- Conc.await a2@@ -120,18 +125,18 @@                 "Different keys execute independently"                 [ testCase "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)+                        r1 <- with 1 (compute 10)+                        r2 <- with 2 (compute 20)+                        r3 <- with 3 (compute 30)                         pure [r1, r2, r3]                     results @?= [10, 20, 30]                     execCount @?= 3                 , testCase "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)+                        a1 <- Conc.fork $ with 1 (slowCompute sem 10)+                        a2 <- Conc.fork $ with 2 (slowCompute sem 20)+                        a3 <- Conc.fork $ with 3 (slowCompute sem 30)                         replicateM_ 3 $ Sem.signal sem                         r1 <- Conc.await a1                         r2 <- Conc.await a2@@ -144,15 +149,15 @@                 "UpdateCache pre-populates the cache"                 [ testCase "returns pre-populated value without executing computation" $ do                     (result, execCount) <- runSingleflightTest $ do-                        updateCache [(1, 99)]-                        withCache 1 (compute 42)+                        update [(1, 99)]+                        with 1 (compute 42)                     result @?= 99                     execCount @?= 0                 , testCase "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)+                        update [(1, 99)]+                        r1 <- with 1 (compute 42)+                        r2 <- with 1 (compute 42)                         pure [r1, r2]                     results @?= [99, 99]                     execCount @?= 0@@ -161,10 +166,10 @@                 "UpdateCache handles multiple entries"                 [ testCase "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)+                        update [(1, 10), (2, 20), (3, 30)]+                        r1 <- with 1 (compute 99)+                        r2 <- with 2 (compute 99)+                        r3 <- with 3 (compute 99)                         pure [r1, r2, r3]                     results @?= [10, 20, 30]                     execCount @?= 0@@ -176,7 +181,7 @@                         -- Start one slow computation and many fast waiters                         asyncs <- replicateM 20 do                             sem <- Sem.new-                            async <- Conc.fork $ withCache 1 (slowCompute sem 777)+                            async <- Conc.fork $ with 1 (slowCompute sem 777)                             pure (sem, async)                         traverse_ Sem.signal $ fst <$> asyncs                         traverse Conc.await $ snd <$> asyncs@@ -191,26 +196,26 @@                 "Computation throws exception"                 [ testCase "propagates exception to the first caller" $ do                     let action = runSingleflightTest $ do-                            withCache @Int @Int 1 (throwIO $ TestException "boom")+                            with @Int @Int 1 (throwIO $ TestException "boom")                     result <- try action                     result @?= Left (TestException "boom")                 , testCase "exception does not get cached" $ do                     (result, execCount) <- runSingleflightTest $ do                         -- First request throws                         _ <--                            (withCache @Int @Int 1 (throwIO $ TestException "boom"))+                            (with @Int @Int 1 (throwIO $ TestException "boom"))                                 `catch` \(_ :: TestException) -> pure 0                         -- Second request should re-execute-                        withCache 1 (compute 42)+                        with 1 (compute 42)                     result @?= 42                     execCount @?= 1                 , testCase "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"))+                                Conc.fork $ with @Int @Int 1 (slowCompute sem 42 >> throwIO (TestException "concurrent-boom"))                             Delay.wait (1 :: Millisecond)-                            a2 <- Conc.fork $ withCache @Int @Int 1 (compute 99)+                            a2 <- Conc.fork $ with @Int @Int 1 (compute 99)                             Sem.signal sem                             _ <- Conc.await a1                             Conc.await a2@@ -223,10 +228,10 @@                     (result, execCount) <- runSingleflightTest $ do                         sem <- Sem.new                         -- Start slow computation-                        a1 <- Conc.fork $ withCache 1 (slowCompute sem 42)+                        a1 <- Conc.fork $ with 1 (slowCompute sem 42)                         Delay.wait (1 :: Millisecond) -- Let it start                         -- Update cache while computation is running-                        updateCache [(1, 999)]+                        update [(1, 999)]                         -- Both should get the updated value                         Sem.signal sem                         Conc.await a1@@ -236,12 +241,12 @@                     (results, execCount) <- runSingleflightTest $ do                         sem <- Sem.new                         -- Start slow computation and waiters-                        a1 <- Conc.fork $ withCache 1 (slowCompute sem 42)+                        a1 <- Conc.fork $ with 1 (slowCompute sem 42)                         Delay.wait (1 :: Millisecond)-                        a2 <- Conc.fork $ withCache 1 (compute 42)+                        a2 <- Conc.fork $ with 1 (compute 42)                         Delay.wait (1 :: Millisecond)                         -- Update while they're all waiting/running-                        updateCache [(1, 888)]+                        update [(1, 888)]                         Sem.signal sem                         r1 <- Conc.await a1                         r2 <- Conc.await a2

@@ -3,32 +3,28 @@ 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 Effectful.State.Static.Shared (modify) import Hedgehog (forAll, property, (===)) import Test.Tasty (TestTree, testGroup) import Test.Tasty.HUnit (testCase, (@?=)) import Test.Tasty.Hedgehog (testProperty) +import Effectful.Concurrent qualified as Concurrent import Effectful.Concurrent.STM qualified as STM+import Effectful.Reader.Static qualified as Reader+import Effectful.State.Static.Shared qualified as State 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)+import Atelier.Effects.Cache (Config (..)) +import Atelier.Effects.Cache qualified as Cache+import Atelier.Effects.Clock qualified as Clock+import Atelier.Effects.Conc qualified as Conc+import Atelier.Effects.Delay qualified as Delay+import Atelier.Effects.Log qualified as Log + test_Cache :: TestTree test_Cache =     testGroup@@ -36,53 +32,53 @@         [ testGroup             "Basic Operations"             [ testCase "lookup on absent key returns Nothing" do-                result <- runCacheTest $ cacheLookup 1+                result <- runCacheTest $ Cache.lookup 1                 result @?= Nothing             , testCase "lookup after insert returns Just value" do                 result <- runCacheTest do-                    cacheInsert 1 42-                    cacheLookup 1+                    Cache.insert 1 42+                    Cache.lookup 1                 result @?= Just 42             , testCase "lookup after delete returns Nothing" do                 result <- runCacheTest $ do-                    cacheInsert 1 42-                    cacheDelete 1-                    cacheLookup 1+                    Cache.insert 1 42+                    Cache.delete 1+                    Cache.lookup 1                 result @?= Nothing             , testCase "insert twice updates value" do                 result <- runCacheTest $ do-                    cacheInsert 1 42-                    cacheInsert 1 99-                    cacheLookup 1+                    Cache.insert 1 42+                    Cache.insert 1 99+                    Cache.lookup 1                 result @?= Just 99             , testCase "delete on absent key is a no-op" do                 result <- runCacheTest $ do-                    cacheDelete 1-                    cacheLookup 1+                    Cache.delete 1+                    Cache.lookup 1                 result @?= Nothing             ]         , testGroup             "Modify"             [ testCase "modify on absent key uses Nothing branch" do-                result <- runCacheTest $ cacheModify @Int @Int 1 (maybe 0 (+ 1))+                result <- runCacheTest $ Cache.modify @Int @Int 1 (maybe 0 (+ 1))                 result @?= 0             , testCase "modify on present key uses Just branch" do                 result <- runCacheTest $ do-                    cacheInsert 1 10-                    cacheModify 1 (maybe 0 (+ 1))+                    Cache.insert 1 10+                    Cache.modify 1 (maybe 0 (+ 1))                 result @?= 11             , testCase "modify returns the new value" do                 result <- runCacheTest $ do-                    _ <- cacheModify 1 (maybe 5 (+ 5))-                    cacheModify 1 (maybe 5 (+ 5))+                    _ <- Cache.modify 1 (maybe 5 (+ 5))+                    Cache.modify 1 (maybe 5 (+ 5))                 result @?= 10             ]         , testGroup             "TTL Eviction"             [ testCase "entry is present before TTL expires" do                 result <- runBase . runCacheTestWithWait (STM.atomically STM.retry) $ do-                    cacheInsert 1 42-                    cacheLookup 1+                    Cache.insert 1 42+                    Cache.lookup 1                 result @?= Just 42             , testCase "entry is evicted after cleanup thread fires past TTL" do                 result <- runBase do@@ -90,11 +86,11 @@                     done <- STM.atomically STM.newEmptyTMVar                     runCacheTestWithWait (cleanupBarrier done trigger) do                         awaitReady done-                        cacheInsert 1 42-                        v1 <- cacheLookup 1+                        Cache.insert 1 42+                        v1 <- Cache.lookup 1                         modify (addUTCTime (ttl + 1))                         stepCleanup trigger done -- run one cleanup, block until it finishes-                        v2 <- cacheLookup 1+                        v2 <- Cache.lookup 1                         pure (v1, v2)                 result @?= (Just 42, Nothing)             , testCase "entry within TTL survives cleanup" do@@ -103,10 +99,10 @@                     done <- STM.atomically STM.newEmptyTMVar                     runCacheTestWithWait (cleanupBarrier done trigger) do                         awaitReady done-                        cacheInsert 1 42+                        Cache.insert 1 42                         modify (addUTCTime (ttl - 1))                         stepCleanup trigger done-                        cacheLookup 1+                        Cache.lookup 1                 result @?= Just 42             , testCase "re-inserted entry retains original TTL window" do                 result <- runBase do@@ -114,19 +110,19 @@                     done <- STM.atomically STM.newEmptyTMVar                     runCacheTestWithWait (cleanupBarrier done trigger) do                         awaitReady done-                        cacheInsert 1 42-                        v1 <- cacheLookup 1+                        Cache.insert 1 42+                        v1 <- Cache.lookup 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+                        Cache.insert 1 99+                        v2 <- Cache.lookup 1                          -- advance clock past original TTL                         modify (addUTCTime 2)                         stepCleanup trigger done-                        v3 <- cacheLookup 1+                        v3 <- Cache.lookup 1                          pure (v1, v2, v3)                 -- createdAt was preserved from the first insert, so the entry is expired and evicted@@ -137,17 +133,17 @@             [ testProperty "insert then lookup roundtrips value" $ property do                 v <- forAll $ Gen.int (Range.linear 0 1000)                 result <- liftIO $ runCacheTest $ do-                    cacheInsert 1 v-                    cacheLookup 1+                    Cache.insert 1 v+                    Cache.lookup 1                 result === Just v             , testProperty "distinct keys have independent values" $ property 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+                    Cache.insert 1 m+                    Cache.insert 2 n+                    va <- Cache.lookup 1+                    vb <- Cache.lookup 2                     pure (va, vb)                 a === Just m                 b === Just n@@ -155,8 +151,8 @@                 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))+                    let step True = Cache.modify @Int 1 (maybe 1 (+ 1))+                        step False = Cache.modify @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]@@ -165,28 +161,28 @@             , testProperty "concurrent inserts to different keys don't interfere" $ property 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]+                    for_ [1 .. n] \i -> Cache.insert i i+                    traverse (\i -> Cache.lookup i) [1 .. n]                 results === map (Just . id) [1 .. n]             , testProperty "modify is atomic under concurrency" $ property do                 n <- forAll $ Gen.int (Range.linear 1 50)                 finalVal <- liftIO $ runCacheTest $ do-                    for_ [1 .. n] \_ -> cacheModify 1 (maybe 1 (+ 1))-                    cacheLookup 1+                    for_ [1 .. n] \_ -> Cache.modify 1 (maybe 1 (+ 1))+                    Cache.lookup 1                 finalVal === Just n             ]         ]   where-    runBase = runEff . runConcurrent+    runBase = runEff . Concurrent.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+        Log.runNoOp+            . Conc.runIO+            . Delay.runIO+            . State.evalState epoch+            . Clock.runState+            . Reader.runReader (Config {entryTtl = ttl, cleanupInterval = 3600})+            . Cache.runTTLWithWait @Int @Int wait     epoch = UTCTime (fromGregorian 1970 1 1) 0     ttl = 3600 :: NominalDiffTime 

@@ -10,73 +10,75 @@ 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.Effects.Chan (Chan) import Atelier.Time (Millisecond, Second) +import Atelier.Effects.Chan qualified as Chan + test_Chan :: TestTree test_Chan =     testGroup         "Chan"         [ testGroup             "Basic Operations"-            [ testCase "writeChan then readChan roundtrips a value" do+            [ testCase "Chan.write then Chan.read roundtrips a value" do                 result <- runChanTest $ do-                    (inChan, outChan) <- newChan-                    writeChan inChan (42 :: Int)-                    readChan outChan+                    (inChan, outChan) <- Chan.new+                    Chan.write inChan (42 :: Int)+                    Chan.read outChan                 result @?= 42             , testProperty "preserves FIFO order" $ property 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)+                    (inChan, outChan) <- Chan.new+                    traverse_ (Chan.write inChan) xs+                    replicateM (length xs) (Chan.read outChan)                 result === xs-            , testCase "dupChan creates an independent reader that receives the same messages" do+            , testCase "Chan.dup 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+                    (inChan, outChan1) <- Chan.new+                    outChan2 <- Chan.dup inChan+                    Chan.write inChan (42 :: Int)+                    v1 <- Chan.read outChan1+                    v2 <- Chan.read outChan2                     pure (v1, v2)                 result @?= (42, 42)             ]         , testGroup-            "readChanBatched"+            "Chan.readBatched"             [ testGroup                 "when items fill the batch before timeout"                 [ testCase "returns a full batch" do                     result <- runChanTest $ do-                        (inChan, outChan) <- newChan-                        traverse_ (writeChan inChan) [1, 2, 3 :: Int]-                        readChanBatched (1 :: Second) 3 outChan+                        (inChan, outChan) <- Chan.new+                        traverse_ (Chan.write inChan) [1, 2, 3 :: Int]+                        Chan.readBatched (1 :: Second) 3 outChan                     result @?= (1 :| [2, 3])                 , testProperty "caps at batchSize even when more items are available" $ property 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+                        (inChan, outChan) <- Chan.new+                        traverse_ (Chan.write inChan) [1 .. n]+                        Chan.readBatched (1 :: Second) batchSize outChan                     length result === batchSize                 ]             , testGroup                 "when timeout fires before batch is full"                 [ testCase "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+                        (inChan, outChan) <- Chan.new+                        Chan.write inChan (1 :: Int)+                        Chan.readBatched (1 :: Millisecond) 5 outChan                     result @?= (1 :| [])                 , testCase "returns a partial batch" do                     result <- runChanTest $ do-                        (inChan, outChan) <- newChan-                        writeChan inChan (1 :: Int)-                        writeChan inChan 2-                        readChanBatched (1 :: Millisecond) 5 outChan+                        (inChan, outChan) <- Chan.new+                        Chan.write inChan (1 :: Int)+                        Chan.write inChan 2+                        Chan.readBatched (1 :: Millisecond) 5 outChan                     result @?= (1 :| [2])                 ]             ]@@ -88,4 +90,4 @@ --------------------------------------------------------------------------------  runChanTest :: Eff '[Chan, Timeout, IOE] a -> IO a-runChanTest = runEff . runTimeout . runChan+runChanTest = runEff . runTimeout . Chan.run

@@ -25,12 +25,15 @@ import Test.Tasty (TestTree, testGroup) import Test.Tasty.HUnit (testCase, (@?=)) -import Atelier.Effects.Chan (Chan, runChan)-import Atelier.Effects.Clock (Clock, runClock)-import Atelier.Effects.Conc (Conc, fork, fork_, runConc, scoped)+import Atelier.Effects.Chan (Chan)+import Atelier.Effects.Clock (Clock)+import Atelier.Effects.Conc (Conc) import Atelier.Effects.PubSub.Pub (Pub) import Atelier.Effects.PubSub.Sub (Sub) +import Atelier.Effects.Chan qualified as Chan+import Atelier.Effects.Clock qualified as Clock+import Atelier.Effects.Conc qualified as Conc import Atelier.Effects.Iterator qualified as Iter import Atelier.Effects.PubSub qualified as PubSub import Atelier.Effects.PubSub.Pub qualified as Pub@@ -58,16 +61,16 @@                         timeout testTimeoutMicros                             $ runConcTest                             $ replicateM_ iterations-                            $ scoped (void (fork_ blockForever))+                            $ Conc.scoped (void (Conc.fork_ blockForever))                     completed @?= Just ()                 , testCase "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)+                            $ Conc.scoped do+                                _ <- Conc.fork (liftIO (threadDelay 5))+                                void (Conc.fork_ blockForever)                     completed @?= Just ()                 ]           , -- Faithful repro of the actual full-suite victim: the 'fromEvents' Iterator@@ -85,7 +88,7 @@                             $ runIterTest                             $ replicateM_ iterations                             $ Iter.fromEvents @Int \iter -> do-                                _ <- fork do+                                _ <- Conc.fork do                                     liftIO (threadDelay publishDelayUs)                                     traverse_ Pub.publish [1, 2, 3 :: Int]                                 _ <- replicateM 3 (Iter.next iter)@@ -105,7 +108,7 @@                         completed <-                             timeout testTimeoutMicros                                 $ runConcTest-                                $ scoped (void (fork_ nonAllocatingSpin))+                                $ Conc.scoped (void (Conc.fork_ nonAllocatingSpin))                         completed @?= Just ()                     ]                | runSpin@@ -128,9 +131,9 @@   runConcTest :: Eff '[Conc, Concurrent, IOE] a -> IO a-runConcTest = runEff . runConcurrent . runConc+runConcTest = runEff . runConcurrent . Conc.runIO   -- | Mirrors 'IteratorSpec.runTest' — the full effect stack the real victim runs on. runIterTest :: Eff '[Pub Int, Sub Int, Chan, Clock, Conc, Concurrent, IOE] a -> IO a-runIterTest = runEff . runConcurrent . runConc . runClock . runChan . PubSub.run @Int+runIterTest = runEff . runConcurrent . Conc.runIO . Clock.runIO . Chan.run . PubSub.run @Int

@@ -13,8 +13,8 @@ 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.Effects.Conc (Conc, await, awaitAll, fork, forkTry, fork_, runIO, scoped)+import Atelier.Effects.Delay (Delay) import Atelier.Time (Millisecond)  import Atelier.Effects.Delay qualified as Delay@@ -130,8 +130,8 @@ --------------------------------------------------------------------------------  runTest :: Eff '[Delay, Conc, Concurrent, IOE] a -> IO a-runTest = runEff . runConcurrent . runConc . runDelay+runTest = runEff . runConcurrent . runIO . Delay.runIO   runTestSimple :: Eff '[Conc, Concurrent, IOE] a -> IO a-runTestSimple = runEff . runConcurrent . runConc+runTestSimple = runEff . runConcurrent . runIO

@@ -4,7 +4,7 @@ import Test.Tasty (TestTree, testGroup) import Test.Tasty.HUnit (testCase, (@?=)) -import Atelier.Effects.Console (runConsoleToList)+import Atelier.Effects.Console (runToList)  import Atelier.Effects.Console qualified as Console @@ -14,35 +14,35 @@     testGroup         "Console"         [ testGroup-            "runConsoleToList"+            "runToList"             [ testGroup                 "when nothing is logged"                 [ testCase "returns an empty list" $ do-                    let (_, msgs) = runPureEff $ runConsoleToList $ pure ()+                    let (_, msgs) = runPureEff $ runToList $ pure ()                     msgs @?= []                 ]             , testGroup                 "when logging once"                 [ testCase "collects a single traced message" $ do-                    let (_, msgs) = runPureEff $ runConsoleToList $ Console.putStr "hello"+                    let (_, msgs) = runPureEff $ runToList $ Console.putStr "hello"                     msgs @?= ["hello"]                 ]             , testCase "collects multiple logged messages in order" $ do                 let (_, msgs) =-                        runPureEff . runConsoleToList $ do+                        runPureEff . runToList $ do                             Console.putStr "first"                             Console.putStr "second"                             Console.putStr "third"                 msgs @?= ["first", "second", "third"]             , testCase "returns the result alongside the traced messages" $ do                 let (result, msgs) =-                        runPureEff . runConsoleToList $ do+                        runPureEff . runToList $ do                             Console.putStr "side effect"                             pure (42 :: Int)                 result @?= 42                 msgs @?= ["side effect"]             , testCase "traceLn appends a newline to the message" $ do-                let (_, msgs) = runPureEff $ runConsoleToList $ Console.putStrLn "line"+                let (_, msgs) = runPureEff $ runToList $ Console.putStrLn "line"                 msgs @?= ["line\n"]             ]         ]

@@ -10,28 +10,20 @@ 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.Effects.Debounce (Entry (..), ensureCallback, ensureEntry) import Atelier.Time (Millisecond)  import Atelier.Effects.Conc qualified as Conc import Atelier.Effects.Console qualified as Console+import Atelier.Effects.Debounce qualified as Debounce import Atelier.Effects.Delay qualified as Delay   test_Debounce :: TestTree test_Debounce =     testGroup-        "Debounce"-        [ testGroup "runDebounce" testRunDebounce+        "Atelier.Effects.Debounce"+        [ testGroup "run" testRun         , testGroup "ensureEntry" testEnsureEntry         , testGroup "ensureCallback" testEnsureCallback         ]@@ -127,9 +119,9 @@     runCallbackTest =         runEff             . runConcurrent-            . Console.runConsole-            . Delay.runDelay-            . runConc+            . Console.runIO+            . Delay.runIO+            . Conc.runIO     entry generation =         Entry             { generation@@ -143,16 +135,16 @@ -- 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 :: [TestTree]-testRunDebounce =+testRun :: [TestTree]+testRun =     [ testGroup-        "debounced"+        "Debounce.with"         [ testGroup             "when invoked once"             [ testCase "fires once" do                 n <- runTest do                     (count, fired) <- newCounter-                    debounced 50 () (bump count fired)+                    Debounce.with 50 () (bump count fired)                     awaitFire fired                     Delay.wait @Millisecond 80                     readCount count@@ -163,9 +155,9 @@             [ testCase "fires once" do                 n <- runTest do                     (count, fired) <- newCounter-                    debounced 50 () (bump count fired)-                    debounced 50 () (bump count fired)-                    debounced 50 () (bump count fired)+                    Debounce.with 50 () (bump count fired)+                    Debounce.with 50 () (bump count fired)+                    Debounce.with 50 () (bump count fired)                     awaitFire fired                     Delay.wait @Millisecond 80                     readCount count@@ -176,11 +168,11 @@             [ testCase "fires once per burst" do                 n <- runTest do                     (count, fired) <- newCounter-                    debounced 50 () (bump count fired)-                    debounced 50 () (bump count fired)+                    Debounce.with 50 () (bump count fired)+                    Debounce.with 50 () (bump count fired)                     awaitFire fired -- burst 1 settled and cleared the entry-                    debounced 50 () (bump count fired)-                    debounced 50 () (bump count fired)+                    Debounce.with 50 () (bump count fired)+                    Debounce.with 50 () (bump count fired)                     awaitFire fired -- burst 2 is therefore independent                     readCount count                 n @?= 2@@ -190,7 +182,7 @@             [ testCase "should not crash" do                 n <- runTest do                     (count, fired) <- newCounter-                    replicateM_ 10_000 $ debounced 50 () (bump count fired)+                    replicateM_ 10_000 $ Debounce.with 50 () (bump count fired)                     awaitFire fired                     Delay.wait @Millisecond 80                     readCount count@@ -198,13 +190,13 @@             ]         ]     , testGroup-        "debouncedWith"+        "Debounce.withArg"         [ testGroup             "when invoked once"             [ testCase "fires callback with the provided arg" do                 got <- runTest do                     result <- STM.atomically STM.newEmptyTMVar-                    debouncedWith 50 (+) () (42 :: Int) (signal result)+                    Debounce.withArg 50 (+) () (42 :: Int) (signal result)                     awaitValue result                 got @?= Just 42             ]@@ -214,9 +206,9 @@                 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+                    Debounce.withArg 50 (+) () (1 :: Int) cb+                    Debounce.withArg 50 (+) () (2 :: Int) cb+                    Debounce.withArg 50 (+) () (3 :: Int) cb                     awaitFire fired                     Delay.wait @Millisecond 80                     readCount count@@ -225,9 +217,9 @@                 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+                    Debounce.withArg 50 (+) () (1 :: Int) cb+                    Debounce.withArg 50 (+) () (2 :: Int) cb+                    Debounce.withArg 50 (+) () (3 :: Int) cb                     awaitValue result                 got @?= Just 6             ]@@ -238,11 +230,11 @@                     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+                    Debounce.withArg 50 (+) () (1 :: Int) cb+                    Debounce.withArg 50 (+) () (2 :: Int) cb                     awaitFire fired -- burst 1 fired (1+2=3); entry cleared-                    debouncedWith 50 (+) () (10 :: Int) cb-                    debouncedWith 50 (+) () (20 :: Int) cb+                    Debounce.withArg 50 (+) () (10 :: Int) cb+                    Debounce.withArg 50 (+) () (20 :: Int) cb                     awaitFire fired -- burst 2 fired (10+20=30)                     STM.atomically (STM.readTVar ref)                 xs @?= [3, 30]@@ -253,9 +245,9 @@     runTest =         runEff             . runConcurrent-            . runConc-            . runDelay-            . runDebounce+            . Conc.runIO+            . Delay.runIO+            . Debounce.run      -- A fire counter paired with a TMVar signalling that a fire happened.     newCounter = do

@@ -141,4 +141,4 @@     :: Map FilePath ByteString     -> Eff '[FileSystem, State (Map FilePath ByteString)] a     -> a-run fs = runPureEff . evalState fs . runFileSystemState+run fs = runPureEff . evalState fs . runState

@@ -14,18 +14,18 @@ import Hedgehog.Range qualified as Range  import Atelier.Effects.FileWatcher-    ( FileEvent (..)-    , FileWatcher-    , Watch+    ( FileWatcher     , deduplicateDirs-    , dir-    , dirWhere     , matchesAny-    , runFileWatcherScripted     , watchFilePaths     )+import Atelier.Effects.FileWatcher.Event (Event (..))+import Atelier.Effects.FileWatcher.Watch (Watch) +import Atelier.Effects.FileWatcher qualified as FileWatcher+import Atelier.Effects.FileWatcher.Watch qualified as Watch + test_FileWatcher :: TestTree test_FileWatcher =     testGroup@@ -54,17 +54,17 @@         , testGroup             "matchesAny"             [ testCase "matches a file under a watched directory" do-                matchesAny [dir "/proj/src"] "/proj/src/Foo.hs"+                matchesAny [Watch.dir "/proj/src"] "/proj/src/Foo.hs"                     @?= True             , testCase "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"+                matchesAny [Watch.dir "src"] "/proj/src/Foo.hs"                     @?= False             , testCase "applies the file predicate" do-                matchesAny [dirWhere "/proj/src" (\f -> ".hs" `isSuffixOf` f)] "/proj/src/Foo.hs"+                matchesAny [Watch.dirWhere "/proj/src" (\f -> ".hs" `isSuffixOf` f)] "/proj/src/Foo.hs"                     @?= True-                matchesAny [dirWhere "/proj/src" (\f -> ".hs" `isSuffixOf` f)] "/proj/src/Foo.js"+                matchesAny [Watch.dirWhere "/proj/src" (\f -> ".hs" `isSuffixOf` f)] "/proj/src/Foo.js"                     @?= False             ]         , testGroup "runFileWatcherScripted" testScripted@@ -86,7 +86,7 @@             paths <- collectPaths ["/src/Foo.hs", "/src/Bar.hs"]             paths @?= ["/src/Foo.hs", "/src/Bar.hs"]         , testCase "ignores the watch specification" do-            paths <- collectPathsWith [dir "/any"] ["/src/Foo.hs"]+            paths <- collectPathsWith [Watch.dir "/any"] ["/src/Foo.hs"]             paths @?= ["/src/Foo.hs"]         , testCase "passes the full path to the callback unchanged" do             let path = "/home/user/project/src/Some/Deep/Module.hs"@@ -119,7 +119,7 @@   runScripted :: [FilePath] -> Eff '[FileWatcher, Concurrent, IOE] a -> IO a-runScripted paths = runEff . runConcurrent . runFileWatcherScripted (map (,Modified) paths)+runScripted paths = runEff . runConcurrent . FileWatcher.runScripted (map (,Modified) paths)   --------------------------------------------------------------------------------

@@ -6,12 +6,15 @@ import Test.Tasty (TestTree, testGroup) import Test.Tasty.HUnit (testCase, (@?=)) -import Atelier.Effects.Chan (Chan, runChan)-import Atelier.Effects.Clock (Clock, runClock)-import Atelier.Effects.Conc (Conc, fork, runConc)+import Atelier.Effects.Chan (Chan)+import Atelier.Effects.Clock (Clock)+import Atelier.Effects.Conc (Conc) import Atelier.Effects.PubSub.Pub (Pub) import Atelier.Effects.PubSub.Sub (Sub) +import Atelier.Effects.Chan qualified as Chan+import Atelier.Effects.Clock qualified as Clock+import Atelier.Effects.Conc qualified as Conc import Atelier.Effects.Iterator qualified as Iter import Atelier.Effects.PubSub qualified as PubSub import Atelier.Effects.PubSub.Pub qualified as Pub@@ -32,7 +35,7 @@     [ testCase "yields a published event" do         result <- runTest $ do             Iter.fromEvents @Int \iter -> do-                _ <- fork do+                _ <- Conc.fork do                     liftIO $ threadDelay 10                     Pub.publish (42 :: Int)                 Iter.next iter@@ -40,7 +43,7 @@     , testCase "yields events in publication order" do         result <- runTest $ do             Iter.fromEvents @Int \iter -> do-                _ <- fork do+                _ <- Conc.fork do                     liftIO $ threadDelay 10                     traverse_ Pub.publish [1, 2, 3]                 replicateM 3 (Iter.next iter)@@ -48,7 +51,7 @@     , testCase "buffers events so next can catch up" do         result <- runTest $ do             Iter.fromEvents @Int \iter -> do-                _ <- fork do+                _ <- Conc.fork do                     liftIO $ threadDelay 10                     traverse_ Pub.publish [1, 2, 3]                 liftIO $ threadDelay 5_000@@ -62,7 +65,7 @@     [ testCase "passes values that satisfy the predicate" do         result <- runTest $ do             Iter.fromEvents @Int \iter -> do-                _ <- fork do+                _ <- Conc.fork do                     liftIO $ threadDelay 10                     traverse_ Pub.publish [1 .. 4]                 Iter.next (Iter.filter even iter)@@ -70,7 +73,7 @@     , testCase "skips values that do not satisfy the predicate" do         result <- runTest $ do             Iter.fromEvents @Int \iter -> do-                _ <- fork do+                _ <- Conc.fork do                     liftIO $ threadDelay 10                     traverse_ Pub.publish [1 .. 6]                 replicateM 3 (Iter.next (Iter.filter even iter))@@ -83,7 +86,7 @@     [ testCase "skips values equal to the initial value" do         result <- runTest $ do             Iter.fromEvents @Int \iter -> do-                _ <- fork do+                _ <- Conc.fork do                     liftIO $ threadDelay 10                     traverse_ Pub.publish [0, 0, 1]                 Iter.next (Iter.changes 0 iter)@@ -91,7 +94,7 @@     , testCase "yields values that differ from the initial value" do         result <- runTest $ do             Iter.fromEvents @Int \iter -> do-                _ <- fork do+                _ <- Conc.fork do                     liftIO $ threadDelay 10                     traverse_ Pub.publish [1, 2, 3]                 replicateM 3 (Iter.next (Iter.changes 0 iter))@@ -99,7 +102,7 @@     , testCase "skips initial values interspersed with non-initial values" do         result <- runTest $ do             Iter.fromEvents @Int \iter -> do-                _ <- fork do+                _ <- Conc.fork do                     liftIO $ threadDelay 10                     traverse_ Pub.publish [0, 1, 0, 2, 0, 3]                 replicateM 3 (Iter.next (Iter.changes 0 iter))@@ -115,7 +118,7 @@ runTest =     runEff         . runConcurrent-        . runConc-        . runClock-        . runChan+        . Conc.runIO+        . Clock.runIO+        . Chan.run         . PubSub.run @Int

@@ -5,14 +5,16 @@ import Test.Tasty (TestTree, testGroup) import Test.Tasty.HUnit (testCase, (@?=)) -import Atelier.Effects.Log (Log, Message (..), info, runLogWriter, withNamespace)+import Atelier.Effects.Log (Log, Message (..), info, withNamespace) +import Atelier.Effects.Log qualified as Log + runLogTest :: Eff [Log, Writer [Message]] a -> [Message] runLogTest =     runPureEff         . execWriter @[Message]-        . runLogWriter+        . Log.runWriter   test_Log :: TestTree@@ -61,7 +63,7 @@                             fmap (\m -> (m.namespace, m.text))                                 . runPureEff                                 . execWriter @[Message]-                                . runLogWriter+                                . Log.runWriter                                 $ do                                     info "before"                                     withNamespace "scoped" $ info "inside"@@ -76,7 +78,7 @@                             fmap (\m -> (m.namespace, m.text))                                 . runPureEff                                 . execWriter @[Message]-                                . runLogWriter+                                . Log.runWriter                                 . withNamespace "outer"                                 $ do                                     info "outer msg"

@@ -7,12 +7,15 @@ import Test.Tasty (TestTree, testGroup) import Test.Tasty.HUnit (testCase, (@?=)) -import Atelier.Effects.Chan (Chan, runChan)-import Atelier.Effects.Clock (Clock, runClock, runClockConst)-import Atelier.Effects.Conc (Conc, runConc)+import Atelier.Effects.Chan (Chan)+import Atelier.Effects.Clock (Clock)+import Atelier.Effects.Conc (Conc) import Atelier.Effects.PubSub.Pub (Pub) import Atelier.Effects.PubSub.Sub (Sub) +import Atelier.Effects.Chan qualified as Chan+import Atelier.Effects.Clock qualified as Clock+import Atelier.Effects.Conc qualified as Conc import Atelier.Effects.PubSub qualified as PubSub import Atelier.Effects.PubSub.Pub qualified as Pub import Atelier.Effects.PubSub.Sub qualified as Sub@@ -70,9 +73,9 @@ runPubSubTest =     runEff         . runConcurrent-        . runConc-        . runClock-        . runChan+        . Conc.runIO+        . Clock.runIO+        . Chan.run         . PubSub.run @TestEvent  @@ -83,7 +86,7 @@ runPubSubTestWithClock t =     runEff         . runConcurrent-        . runConc-        . runClockConst t-        . runChan+        . Conc.runIO+        . Clock.runConst t+        . Chan.run         . PubSub.run @TestEvent

@@ -13,13 +13,20 @@ 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)+import Atelier.Effects.Cache.Config (Config (..))+import Atelier.Effects.Clock (Clock)+import Atelier.Effects.Conc (Conc)+import Atelier.Effects.Delay (Delay)+import Atelier.Effects.Log (Log)+import Atelier.Effects.Tally (Tally) +import Atelier.Effects.Clock qualified as Clock+import Atelier.Effects.Conc qualified as Conc+import Atelier.Effects.Delay qualified as Delay+import Atelier.Effects.Log qualified as Log+import Atelier.Effects.Tally qualified as Tally + test_Tally :: TestTree test_Tally =     testGroup@@ -31,34 +38,17 @@                 result @?= Map.fromList [(1, 1), (42, 1), (999, 1)]             ]         , testGroup-            "Custom Classifiers"-            [ testCase "identity classifier returns the raw hit count" do-                result <- runTallyTest $ replicateM 4 (withTallyCheck @Int 1 id pure)-                result @?= [1, 2, 3, 4 :: Int]-            , testCase "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 @?= [Nothing, Nothing, Just False, Just False, Just True, Just True]-            , testCase "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 @?= [(1, False), (2, False), (3, True), (4, True)]-            ]-        , testGroup             "Action Execution"             [ testCase "continuation with side effects executes correctly" do                 result <- runTallyTest $ do-                    ref <- liftIO $ IORef.newIORef ([] :: [(Int, Bool)])+                    ref <- liftIO $ IORef.newIORef ([] :: [Int])                     replicateM_ 3-                        $ withTallyCheck @Int 1 (\c -> (c, c > 2))-                        $ \(count, exceeded) ->-                            liftIO $ IORef.modifyIORef' ref ((count, exceeded) :)+                        $ Tally.count @Int+                            1+                            \count ->+                                liftIO $ IORef.modifyIORef' ref (count :)                     liftIO $ reverse <$> IORef.readIORef ref-                result @?= [(1, False), (2, False), (3, True)]+                result @?= [1, 2, 3]             ]         , testGroup             "Properties"@@ -72,11 +62,6 @@                     replicateM_ n checkCount                     checkCount                 finalCount === n + 1-            , testProperty "classifier output is passed through unchanged" $ property $ 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]             ]         ] @@ -90,23 +75,23 @@ runTallyTest action =     runEff         . runConcurrent-        . runLogNoOp-        . runConc-        . runDelay-        . runClock+        . Log.runNoOp+        . Conc.runIO+        . Delay.runIO+        . Clock.runIO         . runReader (Config {entryTtl = 3600, cleanupInterval = 3600})-        . runTally @Int+        . Tally.run @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+checkCount = Tally.count @Int 1 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+checkCountForKey key = Tally.count key pure   -- | Increment the tally for each key and return a map of key → count

@@ -7,10 +7,9 @@ import Test.Tasty (TestTree, testGroup) import Test.Tasty.HUnit (testCase, (@?=)) -import Atelier.Effects.Chan (runChan)-import Atelier.Effects.Conc (runConc)- import Atelier.Effects.Await qualified as Await+import Atelier.Effects.Chan qualified as Chan+import Atelier.Effects.Conc qualified as Conc import Atelier.Effects.Yield qualified as Yield  @@ -115,7 +114,7 @@         xs @?= [1, 2, 3, 1, 2, 3, 1]     ]   where-    runTest = runEff . runConcurrent . runConc . runChan . execWriter+    runTest = runEff . runConcurrent . Conc.runIO . Chan.run . execWriter   testWithYieldToList :: [TestTree]

@@ -0,0 +1,66 @@+module Unit.Atelier.Types.JSON.WithDefaultsSpec (test_WithDefaults) where++import Data.Aeson (FromJSON, ToJSON, eitherDecode)+import Data.Default (Default (..))+import Test.Tasty (TestTree, testGroup)+import Test.Tasty.HUnit (testCase, (@?=))++import Data.ByteString.Lazy qualified as LBS++import Atelier.Types.JSON.QuietSnake (QuietSnake (..))+import Atelier.Types.JSON.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+++test_WithDefaults :: TestTree+test_WithDefaults =+    testGroup+        "WithDefaults"+        [ testGroup+            "WithDefaults"+            [ testCase "falls back to Default values for missing non-Maybe fields" do+                let result = decodeWithDefaults "{}"+                result @?= Right def+            , testCase "uses provided values when all fields are present" do+                let result =+                        decodeWithDefaults+                            "{\"required_field\": \"hello\", \"items\": [\"a\", \"b\"], \"count\": 42}"+                result+                    @?= Right+                        Fixture+                            { requiredField = "hello"+                            , items = ["a", "b"]+                            , count = 42+                            }+            , testCase "partial object: provided fields override defaults, missing fall back" do+                let result = decodeWithDefaults "{\"count\": 7}"+                result+                    @?= Right+                        def {count = 7}+            , testCase "explicitly provided empty list overrides the default list" do+                let result = decodeWithDefaults "{\"items\": []}"+                result @?= Right def {items = []}+            ]+        ]

@@ -20,7 +20,7 @@         [ testGroup             "wait"             [ testCase "should halt the computation" do-                runEff . runConcurrent . Conc.runConc . evalState @Int 0 $ do+                runEff . runConcurrent . Conc.runIO . evalState @Int 0 $ do                     sem <- atomically Sem.new                      thread <- Conc.fork do@@ -136,7 +136,7 @@                     atomically $ Sem.peek sem                 result @?= True             , testCase "waits for the semaphore before running" do-                result <- runEff . runConcurrent . Conc.runConc $ do+                result <- runEff . runConcurrent . Conc.runIO $ do                     sem <- atomically Sem.new                     ref <- liftIO $ IORef.newIORef False                     _ <- Conc.fork $ do

@@ -19,7 +19,7 @@         [ testGroup             "wait"             [ testCase "should halt the computation" do-                runEff . runConcurrent . Conc.runConc . evalState @Int 0 $ do+                runEff . runConcurrent . Conc.runIO . evalState @Int 0 $ do                     sem <- Sem.new                      thread <- Conc.fork do@@ -135,7 +135,7 @@                     Sem.peek sem                 result @?= True             , testCase "waits for the semaphore before running" do-                result <- runEff . runConcurrent . Conc.runConc $ do+                result <- runEff . runConcurrent . Conc.runIO $ do                     sem <- Sem.new                     ref <- liftIO $ IORef.newIORef False                     _ <- Conc.fork $ do

@@ -1,66 +0,0 @@-module Unit.Atelier.Types.WithDefaultsSpec (test_WithDefaults) where--import Data.Aeson (FromJSON, ToJSON, eitherDecode)-import Data.Default (Default (..))-import Test.Tasty (TestTree, testGroup)-import Test.Tasty.HUnit (testCase, (@?=))--import Data.ByteString.Lazy qualified as LBS--import Atelier.Types.JSON.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---test_WithDefaults :: TestTree-test_WithDefaults =-    testGroup-        "WithDefaults"-        [ testGroup-            "WithDefaults"-            [ testCase "falls back to Default values for missing non-Maybe fields" do-                let result = decodeWithDefaults "{}"-                result @?= Right def-            , testCase "uses provided values when all fields are present" do-                let result =-                        decodeWithDefaults-                            "{\"required_field\": \"hello\", \"items\": [\"a\", \"b\"], \"count\": 42}"-                result-                    @?= Right-                        Fixture-                            { requiredField = "hello"-                            , items = ["a", "b"]-                            , count = 42-                            }-            , testCase "partial object: provided fields override defaults, missing fall back" do-                let result = decodeWithDefaults "{\"count\": 7}"-                result-                    @?= Right-                        def {count = 7}-            , testCase "explicitly provided empty list overrides the default list" do-                let result = decodeWithDefaults "{\"items\": []}"-                result @?= Right def {items = []}-            ]-        ]