atelier-core 0.4.0.1 → 1.0.0.0
raw patch · 86 files changed
Files
- CHANGELOG.md +170/−0
- LICENSE +1/−1
- README.md +7/−22
- atelier-core.cabal +40/−27
- src/Atelier/Config.hs +8/−4
- src/Atelier/Effects/Arguments.hs +20/−13
- src/Atelier/Effects/Arguments/Switch.hs +58/−0
- src/Atelier/Effects/Await.hs +2/−1
- src/Atelier/Effects/Cache.hs +34/−32
- src/Atelier/Effects/Cache/Config.hs +3/−2
- src/Atelier/Effects/Cache/Singleflight.hs +32/−30
- src/Atelier/Effects/Chan.hs +24/−21
- src/Atelier/Effects/Clock.hs +14/−13
- src/Atelier/Effects/Conc.hs +20/−24
- src/Atelier/Effects/Console.hs +23/−11
- src/Atelier/Effects/Debounce.hs +40/−27
- src/Atelier/Effects/Delay.hs +10/−24
- src/Atelier/Effects/Env.hs +18/−19
- src/Atelier/Effects/Exit.hs +17/−20
- src/Atelier/Effects/FSNotify.hs +113/−0
- src/Atelier/Effects/FSNotify/Devel.hs +33/−0
- src/Atelier/Effects/File.hs +10/−12
- src/Atelier/Effects/FileSystem.hs +33/−10
- src/Atelier/Effects/FileSystem/Glob.hs +82/−0
- src/Atelier/Effects/FileWatcher.hs +63/−145
- 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 +21/−17
- src/Atelier/Effects/Internal/Coroutine.hs +7/−6
- src/Atelier/Effects/Iterator.hs +7/−6
- src/Atelier/Effects/Log.hs +50/−27
- src/Atelier/Effects/Posix/Daemons.hs +46/−29
- src/Atelier/Effects/Posix/IO.hs +7/−5
- src/Atelier/Effects/Process.hs +67/−44
- src/Atelier/Effects/Process/Internal.hs +3/−2
- src/Atelier/Effects/PubSub.hs +36/−0
- src/Atelier/Effects/PubSub/Pub.hs +58/−0
- src/Atelier/Effects/PubSub/Sub.hs +157/−0
- src/Atelier/Effects/Publishing.hs +0/−39
- src/Atelier/Effects/Publishing/Pub.hs +0/−57
- src/Atelier/Effects/Publishing/Sub.hs +0/−152
- src/Atelier/Effects/Reader.hs +13/−0
- src/Atelier/Effects/Tally.hs +32/−44
- src/Atelier/Effects/Timeout.hs +52/−31
- src/Atelier/Effects/UUID.hs +0/−37
- src/Atelier/Effects/Yield.hs +2/−1
- src/Atelier/Exception.hs +7/−5
- src/Atelier/Signal.hs +35/−0
- src/Atelier/Time.hs +27/−44
- src/Atelier/Types/Base64.hs +0/−32
- src/Atelier/Types/JSON/Base64.hs +33/−0
- src/Atelier/Types/JSON/QuietSnake.hs +59/−0
- src/Atelier/Types/JSON/ReadShow.hs +38/−0
- src/Atelier/Types/JSON/Renamed.hs +23/−0
- src/Atelier/Types/JSON/StringLiteral.hs +29/−0
- src/Atelier/Types/JSON/WithDefaults.hs +40/−0
- src/Atelier/Types/JsonReadShow.hs +0/−39
- src/Atelier/Types/QuietSnake.hs +0/−44
- src/Atelier/Types/Semaphore.hs +2/−1
- src/Atelier/Types/Semaphore/STM.hs +2/−1
- src/Atelier/Types/WithDefaults.hs +0/−39
- test/Unit/Atelier/ConfigSpec.hs +30/−32
- test/Unit/Atelier/Effects/Arguments/SwitchSpec.hs +66/−0
- test/Unit/Atelier/Effects/AwaitSpec.hs +53/−43
- test/Unit/Atelier/Effects/Cache/SingleflightSpec.hs +207/−187
- test/Unit/Atelier/Effects/CacheSpec.hs +167/−168
- test/Unit/Atelier/Effects/ChanSpec.hs +72/−64
- test/Unit/Atelier/Effects/Conc/TeardownStressSpec.hs +85/−71
- test/Unit/Atelier/Effects/ConcSpec.hs +101/−89
- test/Unit/Atelier/Effects/ConsoleSpec.hs +41/−33
- test/Unit/Atelier/Effects/DebounceSpec.hs +157/−139
- test/Unit/Atelier/Effects/FileSystemSpec.hs +96/−90
- test/Unit/Atelier/Effects/FileWatcherSpec.hs +74/−58
- test/Unit/Atelier/Effects/IteratorSpec.hs +58/−53
- test/Unit/Atelier/Effects/LogSpec.hs +74/−67
- test/Unit/Atelier/Effects/PubSub/PubSpec.hs +62/−0
- test/Unit/Atelier/Effects/PubSubSpec.hs +92/−0
- test/Unit/Atelier/Effects/Publishing/PubSpec.hs +0/−53
- test/Unit/Atelier/Effects/PublishingSpec.hs +0/−85
- test/Unit/Atelier/Effects/TallySpec.hs +60/−70
- test/Unit/Atelier/Effects/YieldSpec.hs +137/−128
- test/Unit/Atelier/Types/JSON/WithDefaultsSpec.hs +66/−0
- test/Unit/Atelier/Types/Semaphore/STMSpec.hs +131/−109
- test/Unit/Atelier/Types/SemaphoreSpec.hs +130/−108
- test/Unit/Atelier/Types/WithDefaultsSpec.hs +0/−63
CHANGELOG.md view
@@ -7,6 +7,176 @@ ## [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++- `Atelier.Effects.Console.runConsoleOut` and `Atelier.Effects.Console.Output`:+ to run `Console` effects against specific well-known handlers, like `stdout`+ and `stderr`.++## [0.8.0.0] - 2026-10-20++### Added++- `Atelier.Types.JSON.StringLiteral`: helper `newtype` for parsing and encoding+ values as exact string literals, regardless of their `Show` and `Read`+ instances.+- `Atelier.Types.JSON.ReadShow`: a copy of `Atelier.Types.JsonReadShow`, but+ with a better name.+- `Atelier.Types.JSON.QuietSnake`: a copy of `Atelier.Types.QuietSnake`, but+ with a better name.+- `Atelier.Effects.Input.withEff`: a copy of+ `Atelier.Effects.Input.runInputEff`, but with a better name.+- `Atelier.Effects.Input.withConst`: a copy of+ `Atelier.Effects.Input.runInputConst`, but with a better name.+- `Atelier.Effects.PubSub`: a copy of+ `Atelier.Effects.Publishing`, but with a better name.+- `Atelier.Effects.PubSub.Pub`: a copy of+ `Atelier.Effects.Publishing.Pub`, but with a better name.+- `Atelier.Effects.PubSub.Sub`: a copy of+ `Atelier.Effects.Publishing.Sub`, but with a better name.+- `Atelier.Effects.Reader.project`: a simple way to expose parts of another+ `Reader a` as another `Reader` effect.+- `Atelier.Effects.Input.map`: a function to transform an existing effect.+- `Atelier.Effects.Log.Config`: gets a `ToJSON` instance.+- `Atelier.Effects.Log.Severity`: gets a `ToJSON` instance.++### Changed++- `Atelier.Effects.Log.Config`: its `FromJSON` instance now fails gracefully+ using the `Default` instance.++### Deprecated++- `Atelier.Types.JsonReadShow`: superseded by `Atelier.Types.JSON.ReadShow`.+- `Atelier.Types.QuietSnake`: superseded by `Atelier.Types.JSON.QuietSnake`.+- `Atelier.Effects.Input.runInputEff`: superseded by `Atelier.Effects.Input.withEff`.+- `Atelier.Effects.Input.runInputConst`: superseded by `Atelier.Effects.Input.withConst`.+- `Atelier.Effects.Publishing`: superseded by `Atelier.Effects.PubSub`.+- `Atelier.Effects.Publishing.runPubSub`: superseded by `Atelier.Effects.PubSub.run`.+- `Atelier.Effects.Publishing.Pub`: superseded by `Atelier.Effects.PubSub.Pub`.+- `Atelier.Effects.Publishing.Sub`: superseded by `Atelier.Effects.PubSub.Sub`.++## [0.7.3.0] - 2026-10-02++### Added++- `Atelier.Effects.FileSystem.getModificationTime`: Lifted `System.Directory.getModificationTime`.++## [0.7.2.0] - 2026-09-21++### Added++- `Atelier.Signal`: For properly handling termination of an application.++## [0.7.1.0] - 2026-09-17++### Added++- Proper support for GHC 9.14.++## [0.7.0.0] - 2026-09-16++### Removed++- Support for GHC 9.14. A faulty CI setup incorrectly stated that we were+ building and testing successfully on GHC 9.14.++## [0.6.1.0] - 2026-09-15++### Added++- `Atelier.Effects.FileSystem.Glob`: lifted functions from the `Glob` library.+- Support for GHC 9.14.++## [0.6.0.0] - 2026-09-10++### Changed++- Require `effectful >=2.7 && <2.8`.+- Require `effectful-core >=2.7 && <2.8`.+- Require `effectful-plugin >=2.2 && <2.3`.++## [0.5.0.0] - 2026-09-09++### Changed++- `Atelier.Time`: Remove orphan `FromJSON` and `ToJSON` instances, and instead+ introduce `AsRawUnit` and `AsJsonMicrosecond` `newtype`s for `FromJSON` and+ `ToJSON` instance deriving. This fixes the issue where the time units'+ `FromJSON` and `ToJSON` instances did not match, meaning+ `decode (encode (10 :: Hour)) == Nothing` held true. Now you have to be more+ explicit about how the units will be represented in JSON.+ ## [0.4.0.1] - 2026-08-14 ### Removed
LICENSE view
@@ -1,6 +1,6 @@ MIT License -Copyright (c) 2025 Christian Georgii+Copyright (c) 2026 Tweag Permission is hereby granted, free of charge, to any person obtaining a copy of this software and associated documentation files (the "Software"), to deal
README.md view
@@ -4,29 +4,14 @@ ## Overview -`atelier-core` provides a set of composable Effectful effects and supporting types for building structured, observable applications.--| Module | Purpose |-|---|---|-| `Atelier.Component` | Structured component lifecycle (`setup → listeners → start`) |-| `Atelier.Config` | Configuration with environment variable overrides |-| `Atelier.Effects.Log` | Structured logging with hierarchical namespaces |-| `Atelier.Effects.Conc` | Thread management via [Ki](https://github.com/awkward-squad/ki) (structured concurrency) |-| `Atelier.Effects.Cache` | Caching with singleflight deduplication |-| `Atelier.Effects.Publishing` | Event publishing with context propagation |-| `Atelier.Effects.Monitoring.Tracing` | OpenTelemetry tracing |-| `Atelier.Effects.Monitoring.Metrics` | Prometheus metrics |-| `Atelier.Effects.FileWatcher` | Filesystem change notifications |-| `Atelier.Effects.Process` | External process management |--It also wraps a number of `IO`-based primitives (environment, clock, file system, console, POSIX) as effects so they can be interpreted and tested explicitly: `Atelier.Effects.Env`, `Atelier.Effects.Clock`, `Atelier.Effects.FileSystem`, `Atelier.Effects.Console`, `Atelier.Effects.Posix.*`, and more.--## Part of atelier+`atelier-core` provides a set of composable Effectful effects and supporting+types for building structured, observable applications. -- [`atelier-prelude`](https://github.com/tweag/tricorder/tree/main/atelier-prelude) — relude-based prelude with Effectful conventions-- [`atelier-core`](https://github.com/tweag/tricorder/tree/main/atelier-core) — this package-- [`atelier-db`](https://github.com/tweag/tricorder/tree/main/atelier-db) — relational database effect (Hasql/Rel8)-- [`atelier-testing`](https://github.com/tweag/tricorder/tree/main/atelier-testing) — database-backed test utilities+It also wraps a number of `IO`-based primitives (environment, clock, file+system, console, POSIX) as effects so they can be interpreted and tested+explicitly: `Atelier.Effects.Env`, `Atelier.Effects.Clock`,+`Atelier.Effects.FileSystem`, `Atelier.Effects.Console`,+`Atelier.Effects.Posix.*`, and more. ## License
atelier-core.cabal view
@@ -5,21 +5,22 @@ -- see: https://github.com/sol/hpack name: atelier-core-version: 0.4.0.1+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 homepage: https://github.com/tweag/tricorder#readme bug-reports: https://github.com/tweag/tricorder/issues-author: Victor Nascimento Bakke+author: Christian Georgii maintainer: victor.bakke@tweag.io license: MIT license-file: LICENSE build-type: Simple tested-with:- GHC == 9.10.3+ GHC == 9.14.1 , GHC == 9.6.7 , GHC == 9.8.4+ , GHC == 9.10.3 , GHC == 9.12.4 extra-doc-files: CHANGELOG.md@@ -33,6 +34,7 @@ exposed-modules: Atelier.Config Atelier.Effects.Arguments+ Atelier.Effects.Arguments.Switch Atelier.Effects.Await Atelier.Effects.Cache Atelier.Effects.Cache.Config@@ -47,7 +49,13 @@ Atelier.Effects.Exit Atelier.Effects.File 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@@ -56,22 +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.JsonReadShow- Atelier.Types.QuietSnake+ Atelier.Types.JSON.Base64+ Atelier.Types.JSON.QuietSnake+ Atelier.Types.JSON.ReadShow+ Atelier.Types.JSON.Renamed+ Atelier.Types.JSON.StringLiteral+ Atelier.Types.JSON.WithDefaults Atelier.Types.Semaphore Atelier.Types.Semaphore.STM- Atelier.Types.WithDefaults other-modules: Paths_atelier_core autogen-modules:@@ -97,8 +108,9 @@ TypeFamilies ghc-options: -Weverything -Wno-unsafe -Wno-missing-safe-haskell-mode -Wno-monomorphism-restriction -Wno-missing-kind-signatures -Wno-missing-local-signatures -Wno-missing-import-lists -Wno-implicit-prelude -Wno-unticked-promoted-constructors -Wno-unused-packages -Wno-all-missed-specialisations -Wno-missed-specialisations -fplugin=Effectful.Plugin -threaded build-depends:- aeson >=2.2 && <2.4- , atelier-prelude >=0.1 && <0.3+ Glob ==0.10.*+ , aeson >=2.2 && <2.4+ , atelier-prelude ==0.4.* , base >=4.18 && <4.23 , base64-bytestring ==1.2.* , bytestring >=0.11 && <0.13@@ -107,9 +119,9 @@ , daemons ==0.4.* , data-default ==0.8.* , directory ==1.3.*- , effectful ==2.6.*- , effectful-core ==2.6.*- , effectful-plugin >=2.0 && <2.2+ , effectful ==2.7.*+ , effectful-core ==2.7.*+ , effectful-plugin ==2.2.* , effectful-th ==1.0.* , filepath >=1.4 && <1.6 , fsnotify ==0.4.*@@ -144,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@@ -156,13 +169,13 @@ Unit.Atelier.Effects.FileWatcherSpec Unit.Atelier.Effects.IteratorSpec Unit.Atelier.Effects.LogSpec- Unit.Atelier.Effects.Publishing.PubSpec- Unit.Atelier.Effects.PublishingSpec+ Unit.Atelier.Effects.PubSub.PubSpec+ Unit.Atelier.Effects.PubSubSpec Unit.Atelier.Effects.TallySpec Unit.Atelier.Effects.YieldSpec+ Unit.Atelier.Types.JSON.WithDefaultsSpec Unit.Atelier.Types.Semaphore.STMSpec Unit.Atelier.Types.SemaphoreSpec- Unit.Atelier.Types.WithDefaultsSpec Paths_atelier_core autogen-modules: Paths_atelier_core@@ -190,22 +203,22 @@ tasty-discover:tasty-discover build-depends: aeson >=2.2 && <2.4- , atelier-core >=0.3 && <0.5- , atelier-prelude >=0.1 && <0.3+ , atelier-core+ , atelier-prelude ==0.4.* , base >=4.18 && <4.23 , bytestring >=0.11 && <0.13 , containers >=0.6 && <0.9 , data-default ==0.8.*- , effectful ==2.6.*- , effectful-core ==2.6.*- , effectful-plugin >=2.0 && <2.2+ , effectful ==2.7.*+ , effectful-core ==2.7.*+ , effectful-plugin ==2.2.* , hedgehog ==1.7.*- , hspec ==2.11.*- , hspec-hedgehog ==0.3.*+ , optparse-applicative ==0.19.* , stm ==2.5.* , stm-containers ==1.2.* , tasty ==1.5.*- , tasty-hspec ==1.2.*+ , tasty-hedgehog ==1.4.*+ , tasty-hunit >=0.10.2 && <0.11 , time >=1.12 && <1.17 mixins: base hiding (Prelude)
src/Atelier/Config.hs view
@@ -45,7 +45,8 @@ , extractNestedConfig , LoadedConfig (..) , runConfig- ) where+ )+where import Data.Aeson (FromJSON (..), Value (..)) import Data.Default (Default (..))@@ -58,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]@@ -155,7 +158,8 @@ -- @ -- extractNestedConfig \@"foo.bar" \@Text cfg == "test" -- @-extractNestedConfig :: forall (key :: Symbol) r. (Default r, FromJSON r, KnownSymbol key) => LoadedConfig -> r+extractNestedConfig+ :: forall (key :: Symbol) r. (Default r, FromJSON r, KnownSymbol key) => LoadedConfig -> r extractNestedConfig (LoadedConfig root) = go props root where props = T.splitOn "." $ toText $ symbolVal $ Proxy @key
src/Atelier/Effects/Arguments.hs view
@@ -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,27 +15,32 @@ , execParser -- * Interpreters- , runArgumentsIO- ) where+ , 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
+ src/Atelier/Effects/Arguments/Switch.hs view
@@ -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
src/Atelier/Effects/Await.hs view
@@ -16,7 +16,8 @@ -- * Interpreters , eachAwait , awaitYield- ) where+ )+where import Atelier.Effects.Internal.Coroutine ( Await
src/Atelier/Effects/Cache.hs view
@@ -2,19 +2,20 @@ 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- ) where+ , runTTL+ , runTTLWithWait+ , runForever+ )+where import Data.Time (NominalDiffTime, UTCTime, addUTCTime) import Effectful (Effect)@@ -45,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@@ -70,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@@ -81,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@@ -103,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))) @@ -117,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@@ -127,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@@ -149,10 +150,11 @@ evictExpiredEntries store ttl now = ListT.fold ( \count (k, v) ->- if now >= addUTCTime ttl v.createdAt then- Map.delete k store $> count + 1- else- pure count+ if now >= addUTCTime ttl v.createdAt+ then+ Map.delete k store $> count + 1+ else+ pure count ) 0 $ Map.listT store@@ -162,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
src/Atelier/Effects/Cache/Config.hs view
@@ -5,13 +5,14 @@ -- "Atelier.Effects.Tally". module Atelier.Effects.Cache.Config ( Config (..)- ) where+ )+where import Data.Aeson (FromJSON) import Data.Default (Default (..)) import Data.Time (NominalDiffTime) -import Atelier.Types.QuietSnake (QuietSnake (..))+import Atelier.Types.JSON.QuietSnake (QuietSnake (..)) -- | Configuration for a TTL-evicting cache
src/Atelier/Effects/Cache/Singleflight.hs view
@@ -7,11 +7,12 @@ -- be seeded with 'updateCache' or invalidated with 'removeFromCache'. module Atelier.Effects.Cache.Singleflight ( Singleflight (..)- , withCache- , updateCache- , removeFromCache- , runSingleflight- ) where+ , with+ , update+ , remove+ , runIO+ )+where import Effectful (Effect) import Effectful.Concurrent (Concurrent)@@ -35,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@@ -50,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@@ -88,24 +89,25 @@ -- Use tryPutTMVar in case updateCache already filled it filled <- STM.atomically $ STM.tryPutTMVar mvar result - if filled then do- -- We successfully filled the TMVar with our result- -- If it was an exception, remove from cache so future requests can retry- case result of- Left _exception -> do- STM.atomically $ Map.delete key cache- Right _ -> pure ()+ if filled+ then do+ -- We successfully filled the TMVar with our result+ -- If it was an exception, remove from cache so future requests can retry+ case result of+ Left _exception -> do+ STM.atomically $ Map.delete key cache+ Right _ -> pure () - -- Return the result or re-throw the exception- case result of- Left exception -> throwIO exception- Right value -> pure value- else do- -- updateCache filled it before us - read and use that value- finalResult <- STM.atomically $ STM.readTMVar mvar- case finalResult of- Left exception -> throwIO exception- Right value -> pure value+ -- Return the result or re-throw the exception+ case result of+ Left exception -> throwIO exception+ Right value -> pure value+ else do+ -- updateCache filled it before us - read and use that value+ finalResult <- STM.atomically $ STM.readTMVar mvar+ case finalResult of+ Left exception -> throwIO exception+ Right value -> pure value (False, Nothing) -> do result <- STM.atomically@@ -113,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@@ -128,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
src/Atelier/Effects/Chan.hs view
@@ -26,11 +26,12 @@ module Atelier.Effects.Chan ( -- * Effect Chan- , newChan- , readChan- , writeChan- , dupChan- , runChan+ , new+ , read+ , write+ , dup+ , run+ , readBatched -- * Channel Types @@ -39,8 +40,8 @@ -- to maintain abstraction boundaries. , InChan , OutChan- , readChanBatched- ) where+ )+where import Control.Concurrent.Chan.Unagi (InChan, OutChan) import Data.Time.Units (TimeUnit, toMicroseconds)@@ -57,37 +58,39 @@ type instance DispatchOf Chan = Static WithSideEffects++ data instance StaticRep Chan = Chan -- | Run the 'Chan' effect, allowing channel operations to perform their IO.-runChan :: forall a es. (IOE :> es) => Eff (Chan : es) a -> Eff es a-runChan = evalStaticRep Chan+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 @@ -96,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@@ -110,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
src/Atelier/Effects/Clock.hs view
@@ -9,11 +9,12 @@ , TimeZone , currentTime , currentTimeZone- , runClock- , runClockConst- , runClockState- , runClockList- ) where+ , runIO+ , runConst+ , runState+ , runList+ )+where import Data.Time (UTCTime, getCurrentTime) import Data.Time.LocalTime (TimeZone, getCurrentTimeZone, utc)@@ -35,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 @@ -60,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"
src/Atelier/Effects/Conc.hs view
@@ -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
src/Atelier/Effects/Console.hs view
@@ -6,22 +6,25 @@ module Atelier.Effects.Console ( -- * Effect Console+ , Output (..) , putStrLn , putStr , putTextLn , putText -- * Interpreters- , runConsoleHandle- , runConsole- , runConsoleToList- ) where+ , runHandle+ , runIO+ , runToList+ , runOut+ )+where import Effectful (Effect, IOE) import Effectful.Dispatch.Dynamic (interpret_, reinterpret_) import Effectful.State.Static.Shared (modify, runState) import Effectful.TH (makeEffect)-import System.IO (Handle, stdout)+import System.IO (Handle, stderr, stdout) import Prelude import Data.ByteString.Char8 qualified as B8@@ -33,6 +36,9 @@ PutStr :: ByteString -> Console m () +data Output = Stdout | Stderr++ makeEffect ''Console @@ -52,18 +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 :)+++runOut :: (IOE :> es) => Output -> Eff (Console : es) a -> Eff es a+runOut = \case+ Stderr -> runHandle stderr+ Stdout -> runHandle stdout
src/Atelier/Effects/Debounce.hs view
@@ -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,38 +14,45 @@ -- @ -- -- 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 , ensureCallback , Entry (..)- ) where+ )+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@@ -61,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)@@ -75,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@@ -99,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@@ -108,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@@ -176,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)
src/Atelier/Effects/Delay.hs view
@@ -1,24 +1,11 @@--- | An effect for delaying execution.------ 'wait' suspends the current thread for a 'TimeUnit' duration; 'every' repeats--- an action forever with a fixed gap between runs. 'runDelay' performs real--- delays, while 'runDelayNoOp' skips them so time-based code runs instantly--- under test.------ @--- -- pause within a workflow:--- wait (250 :: Millisecond)------ -- run a health check every 30 seconds, forever (the caller forks it):--- fork_ $ every (30 :: Second) checkHealth--- @ module Atelier.Effects.Delay ( Delay , wait , every- , runDelay- , runDelayNoOp- ) where+ , runIO+ , runNoOp+ )+where import Data.Time.Units (TimeUnit, toMicroseconds) import Effectful (Effect)@@ -37,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@@ -46,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 ()
src/Atelier/Effects/Env.hs view
@@ -1,18 +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- ) where+ , 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@@ -21,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
src/Atelier/Effects/Exit.hs view
@@ -1,18 +1,16 @@ -- | 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- ) where+ , runIO+ , runNoOp+ )+where import Effectful (Effect, IOE) import Effectful.Dispatch.Dynamic (interpret_, reinterpret_)@@ -26,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
+ src/Atelier/Effects/FSNotify.hs view
@@ -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
+ src/Atelier/Effects/FSNotify/Devel.hs view
@@ -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)
src/Atelier/Effects/File.hs view
@@ -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,8 +16,9 @@ , hPutLBsLn , hIsEOF , hSetBuffering- , runFile- ) where+ , run+ )+where import Effectful (Dispatch (..), DispatchOf, Effect, IOE) import Effectful.Dispatch.Static@@ -45,12 +41,14 @@ type instance DispatchOf File = Static WithSideEffects++ data instance StaticRep File = File -- | Lifted `System.IO.withFile`:-withFile :: (File :> es, HasCallStack) => FilePath -> IOMode -> (Handle -> Eff es a) -> Eff es a-withFile fp m f = unsafeSeqUnliftIO \unlift -> IO.withFile fp m (unlift . f)+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`.@@ -100,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
src/Atelier/Effects/FileSystem.hs view
@@ -19,14 +19,18 @@ , writeFileBS , writeFileLBS , canonicalizePath+ , getModificationTime , getCurrentDirectory , getXdgRuntimeDir- , runFileSystemIO- , runFileSystemNoOp- , runFileSystemState- ) where+ , makeAbsolute+ , runIO+ , runNoOp+ , runState+ )+where import Control.Exception (bracket)+import Data.Time (UTCTime (..)) import Effectful (Effect, IOE) import Effectful.Dispatch.Dynamic (interpret_) import Effectful.Exception (throwIO)@@ -39,6 +43,7 @@ import Data.ByteString qualified as BS import Data.ByteString.Lazy qualified as LBS import Data.Map.Strict qualified as M+import Data.Time.Calendar.OrdinalDate qualified as Day import System.Directory qualified as Dir import System.Posix.IO qualified as Posix @@ -77,6 +82,18 @@ GetCurrentDirectory :: FileSystem m FilePath -- | The XDG runtime directory (@$XDG_RUNTIME_DIR@), falling back to @\/tmp@. 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@@ -104,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@@ -124,12 +141,14 @@ CanonicalizePath path -> liftIO $ Dir.canonicalizePath path 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@@ -143,15 +162,17 @@ CanonicalizePath path -> pure path 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)@@ -174,3 +195,5 @@ CanonicalizePath fp -> pure fp GetCurrentDirectory -> pure "/" GetXdgRuntimeDir -> pure "/tmp"+ GetModificationTime _ -> pure $ UTCTime (Day.fromOrdinalDate 1970 1) 0+ MakeAbsolute path -> pure path
+ src/Atelier/Effects/FileSystem/Glob.hs view
@@ -0,0 +1,82 @@+module Atelier.Effects.FileSystem.Glob+ ( -- * Effect+ Glob (..)+ , globDir+ , globDir1+ , glob+ , globDirWith++ -- * Re-exports from 'System.FilePath.Glob'.+ , module GlobExports++ -- * Interpreters+ , runIO+ , runScripted+ , GlobScript (..)+ )+where++import Effectful (Effect, IOE)+import Effectful.Dispatch.Dynamic (interpret_, reinterpret)+import Effectful.State.Static.Shared (evalState, get, put)+import Effectful.TH (makeEffect)+import System.FilePath.Glob (GlobOptions, Pattern)++import System.FilePath.Glob qualified as Glob+import System.FilePath.Glob qualified as GlobExports hiding (glob, globDir, globDir1, globDirWith)+++data Glob :: Effect where+ -- | Lifted 'Glob.globDir'.+ GlobDir :: [Pattern] -> FilePath -> Glob m [[FilePath]]+ -- | Lifted 'Glob.globDir1'.+ GlobDir1 :: Pattern -> FilePath -> Glob m [FilePath]+ -- | Lifted 'Glob.glob'.+ Glob :: String -> Glob m [FilePath]+ -- | Lifted 'Glob.globDirWith'.+ GlobDirWith :: GlobOptions -> [Pattern] -> FilePath -> Glob m ([[FilePath]], Maybe [FilePath])+++makeEffect ''Glob+++runIO :: (IOE :> es) => Eff (Glob : es) a -> Eff es a+runIO = interpret_ \case+ GlobDir patterns filePath -> liftIO $ Glob.globDir patterns filePath+ GlobDir1 pattern filePath -> liftIO $ Glob.globDir1 pattern filePath+ Glob pattern -> liftIO $ Glob.glob pattern+ GlobDirWith opts patterns filePath -> liftIO $ Glob.globDirWith opts patterns filePath+++-- | Script element for the test interpreter.+data GlobScript+ = -- | Return this result for the next 'globDir' call.+ NextGlobDir [[FilePath]]+ | -- | Return this result for the next 'globDir1' call.+ NextGlobDir1 [FilePath]+ | -- | Return this result for the next 'glob' call.+ NextGlob [FilePath]+ | -- | Return this result for the next 'globDirWith' call.+ NextGlobDirWith ([[FilePath]], Maybe [FilePath])+++-- | Scripted interpreter for testing. Pops the next matching entry off the+-- queue for each call; does not require 'IOE'.+runScripted :: [GlobScript] -> Eff (Glob : es) a -> Eff es a+runScripted script = reinterpret (evalState script) \_ -> \case+ GlobDir _ _ ->+ get >>= \case+ NextGlobDir r : rest -> put rest >> pure r+ _ -> error "GlobScripted: expected NextGlobDir but queue was empty or mismatched"+ GlobDir1 _ _ ->+ get >>= \case+ NextGlobDir1 r : rest -> put rest >> pure r+ _ -> error "GlobScripted: expected NextGlobDir1 but queue was empty or mismatched"+ Glob _ ->+ get >>= \case+ NextGlob r : rest -> put rest >> pure r+ _ -> error "GlobScripted: expected NextGlob but queue was empty or mismatched"+ GlobDirWith _ _ _ ->+ get >>= \case+ NextGlobDirWith r : rest -> put rest >> pure r+ _ -> error "GlobScripted: expected NextGlobDirWith but queue was empty or mismatched"
src/Atelier/Effects/FileWatcher.hs view
@@ -37,127 +37,49 @@ -- 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 , matchesAny- ) where+ )+where -import Control.Concurrent (threadDelay)-import Control.Concurrent.STM (retry) import Data.List (nub)-import Effectful (Effect, IOE)+import Effectful (Effect, Limit (..), Persistence (..), UnliftStrategy (..)) import Effectful.Concurrent (Concurrent)-import Effectful.Concurrent.STM (atomically)-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 Data.Text qualified as T-import System.FSNotify qualified as FSN--import Atelier.Effects.Conc (concStrat)-import Atelier.Effects.Debounce (Debounce, debouncedWith)----- | The kind of filesystem change that triggered a watch callback.-data FileEvent- = -- | A new file was created.- Added- | -- | An existing file was modified.- Modified- | -- | A file was deleted.- Removed- deriving stock (Eq, Show)----- | Merge two 'FileEvent's for the same path within a debounce window.------ Rules (old, new) → result:------ * @(_, Removed)@ → @Removed@: deletion always wins.--- * @(Removed, Added)@ → @Added@: explicit re-creation after deletion.--- * @(Added, _)@ → @Added@: a create-then-write is still a creation.--- * Otherwise → the newer event.-mergeFileEvent :: FileEvent -> FileEvent -> FileEvent-mergeFileEvent _ Removed = Removed-mergeFileEvent Removed Added = Added-mergeFileEvent Added _ = Added-mergeFileEvent _ event = event----- | Specification of a directory to watch recursively, with a file predicate.-data Watch = Watch FilePath (FilePath -> Bool)----- | Watch all files in a directory recursively.-dir :: FilePath -> Watch-dir p = Watch p (const True)----- | Watch files matching a predicate in a directory recursively.------ @--- dirWhere "src" (\f -> takeExtension f == ".hs")--- @-dirWhere :: FilePath -> (FilePath -> Bool) -> Watch-dirWhere = Watch----- | Watch files with a specific extension in a directory recursively.------ @--- dirExt "src" ".hs"--- @-dirExt :: FilePath -> Text -> Watch-dirExt p ext = dirWhere p (\f -> toText (takeExtension f) == ext)-+import System.FSNotify (eventPath) --- | 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 Effectful.Concurrent qualified as Concurrent +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,70 +100,66 @@ 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)- forever $ threadDelay 1_000_000+ 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 blocks--- indefinitely — matching the blocking semantics of 'runFileWatcherIO'.+--+-- Delivers all scripted events to the callback in order, then parks forever,+-- 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 put [] for_ events' \(path, fileEvent) -> unlift $ callback path fileEvent- atomically retry+ forever $ Concurrent.threadDelay maxBound -- 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
+ src/Atelier/Effects/FileWatcher/Event.hs view
@@ -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
+ src/Atelier/Effects/FileWatcher/Watch.hs view
@@ -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
+ src/Atelier/Effects/GenUUID.hs view
@@ -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
src/Atelier/Effects/Input.hs view
@@ -1,34 +1,32 @@ -- | An effect for requesting a value from the environment on each call.------ Unlike 'Effectful.Reader.Static.Reader', 'Input' makes no assumption that the--- value is stable across the computation — each 'input' may observe a different--- value. See the 'Input' type below for the full comparison. module Atelier.Effects.Input ( Input , input- , runInputEff- , runInputConst+ , withEff+ , withConst , toReader , fromState- ) where+ , map+ )+where import Effectful (Effect) import Effectful.Dispatch.Dynamic (interpret_) import Effectful.Reader.Static (Reader, runReader) import Effectful.State.Static.Shared (State) import Effectful.TH (makeEffect)+import Prelude hiding (map) import Effectful.State.Static.Shared qualified as State -- | 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@@ -42,15 +40,15 @@ -- | Runs the passed effectful action every time 'input' is invoked.-runInputEff :: Eff es i -> Eff (Input i : es) a -> Eff es a-runInputEff mk = interpret_ \Input -> mk+withEff :: Eff es i -> Eff (Input i : es) a -> Eff es a+withEff mk = interpret_ \Input -> mk -- | Provides the same value for every invocation of the 'input' operation. -- This is equivalent to using 'Effectful.Reader.Static' or -- 'Effectful.Reader.Local', but is available here for testing.-runInputConst :: i -> Eff (Input i : es) a -> Eff es a-runInputConst = runInputEff . pure+withConst :: i -> Eff (Input i : es) a -> Eff es a+withConst = withEff . pure -- | Retrieves the value once, and exposes it as a 'Reader' effect.@@ -62,3 +60,9 @@ fromState :: (State i :> es) => Eff (Input i : es) a -> Eff es a fromState = interpret_ \Input -> State.get+++-- | Create a new 'Input' effect based on an existing one, effectively+-- "mapping" the existing effect into a new one.+map :: (Input a :> es) => (a -> b) -> Eff (Input b : es) x -> Eff es x+map f = withEff $ f <$> input
src/Atelier/Effects/Internal/Coroutine.hs view
@@ -42,7 +42,8 @@ -- ** Interpreters , awaitYield- ) where+ )+where import Effectful (Effect, UnliftStrategy (..), inject, raiseWith) import Effectful.Dispatch.Dynamic (interpretWith_, interpret_, reinterpretWith_, reinterpret_)@@ -52,11 +53,11 @@ import Atelier.Effects.Chan (Chan) import Atelier.Effects.Conc (Conc)-import Atelier.Effects.Publishing.Sub (Sub)+import Atelier.Effects.PubSub.Sub (Sub) import Atelier.Effects.Chan qualified as Chan import Atelier.Effects.Conc qualified as Conc-import Atelier.Effects.Publishing.Sub qualified as Sub+import Atelier.Effects.PubSub.Sub qualified as Sub -- * Yield@@ -216,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
src/Atelier/Effects/Iterator.hs view
@@ -10,18 +10,19 @@ , fromEvents , filter , changes- ) where+ )+where import Effectful.Concurrent (Concurrent) import Prelude hiding (filter) import Atelier.Effects.Chan (Chan) import Atelier.Effects.Conc (Conc)-import Atelier.Effects.Publishing.Sub (Sub)+import Atelier.Effects.PubSub.Sub (Sub) import Atelier.Effects.Chan qualified as Chan import Atelier.Effects.Conc qualified as Conc-import Atelier.Effects.Publishing.Sub qualified as Sub+import Atelier.Effects.PubSub.Sub qualified as Sub -- | A pull-based iterator of (potentially infinite) values.@@ -46,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.
src/Atelier/Effects/Log.hs view
@@ -37,17 +37,21 @@ , withNamespace -- * Interpreters- , runLog- , runLogNoOp- , runLogToHandle- , runLogWriter- ) where+ , runIO+ , runNoOp+ , runToHandle+ , runWriter -import Data.Aeson (FromJSON (..))+ -- * Utils+ , minimumSeverityFromEnv+ )+where++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)@@ -55,11 +59,14 @@ import Data.ByteString.Char8 qualified as B8 -import Atelier.Effects.Env (Env, getEnvironment)-import Atelier.Types.JsonReadShow (JsonReadShow (..))-import Atelier.Types.QuietSnake (QuietSnake (..))+import Atelier.Effects.Env (Env)+import Atelier.Types.JSON.QuietSnake (QuietSnake (..))+import Atelier.Types.JSON.ReadShow (ReadShow (..))+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'.@@ -101,7 +108,8 @@ -- ^ Messages below this severity are discarded. } deriving stock (Eq, Generic, Show)- deriving (FromJSON) via QuietSnake Config+ deriving (ToJSON) via QuietSnake Config+ deriving (FromJSON) via WithDefaults (QuietSnake Config) -- | Log severity levels, ordered from least to most severe.@@ -115,7 +123,8 @@ | -- | A failure that needs attention. ERROR deriving stock (Bounded, Enum, Eq, Ord, Read, Show)- deriving (FromJSON) via (JsonReadShow Severity)+ deriving (FromJSON) via ReadShow Severity+ deriving (ToJSON) via ReadShow Severity instance Default Config where@@ -164,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@@ -177,16 +186,10 @@ -- 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- env <- getEnvironment- let overrideLog = (>>= readMaybe) $ lookup "LOG" env- overrideLogging = (>>= readMaybe) $ lookup "LOGGING" env- overrideDebug = (>>= \x -> if x == "0" then Nothing else Just DEBUG) $ lookup "DEBUG" env- let severity =- fromMaybe config.minimumSeverity- $ overrideDebug <|> overrideLogging <|> overrideLog+ severity <- fromMaybe config.minimumSeverity <$> minimumSeverityFromEnv reinterpretWith (runReader (Namespace "")) action \lenv -> \case LogMsg msg ->@@ -207,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@@ -220,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@@ -239,6 +242,26 @@ where showNamespace (Namespace "") = "" showNamespace (Namespace ns) = square ns <> " "+++minimumSeverityFromEnv :: (Env :> es) => Eff es (Maybe Severity)+minimumSeverityFromEnv = do+ 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
src/Atelier/Effects/Posix/Daemons.hs view
@@ -1,53 +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- ) where+ , 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
src/Atelier/Effects/Posix/IO.hs view
@@ -19,7 +19,8 @@ module Atelier.Effects.Posix.IO ( readFdAll , readFdFrom- ) where+ )+where import Foreign.Marshal.Alloc (allocaBytes) import Foreign.Ptr (castPtr)@@ -55,10 +56,11 @@ chunk <- allocaBytes chunkSize \ptr -> do n <- Posix.fdReadBuf fd (castPtr ptr) (fromIntegral chunkSize) BS.packCStringLen (castPtr ptr, fromIntegral n)- if BS.null chunk then- return acc- else- go (acc <> Builder.byteString chunk)+ if BS.null chunk+ then+ return acc+ else+ go (acc <> Builder.byteString chunk) -- | Seek to @offset@ and read the remainder of a file descriptor into a lazy
src/Atelier/Effects/Process.hs view
@@ -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,14 +40,14 @@ , getExecutablePath -- * Interpreters- , runProcessIO- ) where+ , 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)@@ -82,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. --@@ -158,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
src/Atelier/Effects/Process/Internal.hs view
@@ -5,11 +5,12 @@ -- operations may target the wrong group. Production code should not import this. module Atelier.Effects.Process.Internal ( RunningProcess (..)- ) where+ )+where import System.Process.Typed qualified as TP -- | 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}
+ src/Atelier/Effects/PubSub.hs view
@@ -0,0 +1,36 @@+module Atelier.Effects.PubSub (run) where++import Data.Time (UTCTime)+import Effectful.Dispatch.Dynamic (interpret, interpret_, localSeqUnlift)++import Atelier.Effects.Chan (Chan)+import Atelier.Effects.Clock (Clock)+import Atelier.Effects.PubSub.Pub (Pub (..))+import Atelier.Effects.PubSub.Sub (Sub (..))++import Atelier.Effects.Chan qualified as Chan+import Atelier.Effects.Clock qualified as Clock+++-- | Runs 'Pub' and 'Sub' effects with an internal channel for a specific event+-- type.+run+ :: forall event es a+ . (Chan :> es, Clock :> es)+ => Eff (Pub event : Sub event : es) a -> Eff es a+run action = do+ (inChan, _) <- Chan.new @(UTCTime, event)+ let handlePub = interpret_ \case+ Publish event -> do+ timestamp <- Clock.currentTime+ Chan.write inChan (timestamp, event)++ handleSub = interpret \env -> \case+ ListenWith onSubscribed listener -> localSeqUnlift env \unlift -> do+ chan <- Chan.dup inChan+ unlift onSubscribed+ forever do+ (timestamp, event) <- Chan.read chan+ unlift $ listener timestamp event++ handleSub . handlePub $ action
+ src/Atelier/Effects/PubSub/Pub.hs view
@@ -0,0 +1,58 @@+module Atelier.Effects.PubSub.Pub+ ( -- * Effect+ Pub (..)+ , publish++ -- * Interpeters+ , noOp+ , toWriter+ , map+ , mapM+ , consume+ )+where++import Effectful (Effect)+import Effectful.Dispatch.Dynamic (interpret_)+import Effectful.TH (makeEffect)+import Effectful.Writer.Static.Shared (Writer, tell)+import Prelude hiding (map, mapM)+++-- | Effect for publishing events of type @event@.+data Pub (event :: Type) :: Effect where+ -- | Publish an event to all current subscribers.+ Publish :: event -> Pub event m ()+++makeEffect ''Pub+++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.+-- Useful for testing and inspecting what events were published.+toWriter :: forall event es a. (Writer [event] :> es) => Eff (Pub event : es) a -> Eff es a+toWriter =+ interpret_ \case+ Publish event -> tell [event]+++-- | Convert published events of one type into another, utilizing an existing+-- effect in the effect stack.+map :: forall e1 e2 es a. (Pub e2 :> es) => (e1 -> e2) -> Eff (Pub e1 : es) a -> Eff es a+map f = interpret_ \(Publish event) -> publish $ f event+++-- | Convert published events of one type into another with an effectful+-- transformation, utilizing an existing effect int he effect stack.+mapM :: forall e1 e2 es a. (Pub e2 :> es) => (e1 -> Eff es e2) -> Eff (Pub e1 : es) a -> Eff es a+mapM f = interpret_ \(Publish event) -> f event >>= publish+++-- | Perform an effectful action for each published event.+consume :: (event -> Eff es ()) -> Eff (Pub event : es) a -> Eff es a+consume handler = interpret_ \case+ Publish event -> handler event
+ src/Atelier/Effects/PubSub/Sub.hs view
@@ -0,0 +1,157 @@+module Atelier.Effects.PubSub.Sub+ ( Sub (..)+ , listen+ , listen_+ , listenWith+ , listenWith_+ , listenOnce+ , listenOnce_+ , listenUntil+ , listenUntil_+ , listenUntilM+ , listenUntilM_+ , forkListener+ , forkListener_+ )+where++import Data.Time (UTCTime)+import Effectful (Effect, inject)+import Effectful.Concurrent.STM+ ( Concurrent+ , atomically+ , newEmptyTMVar+ , putTMVar+ , takeTMVar+ )+import Effectful.Error.Static (runErrorNoCallStack, throwError)+import Effectful.TH (makeEffect)++import Text.Show qualified as S++import Atelier.Effects.Conc (Conc, fork_)+++-- | Effect for subscribing to events of type @event@.+data Sub (event :: Type) :: Effect where+ -- | Subscribe, then run @onSubscribed@ once the subscription is established+ -- — after the internal channel has been duplicated and before any event is+ -- delivered — and thereafter deliver every published event to the listener,+ -- forever. The @onSubscribed@ hook lets a caller synchronize on "subscribed"+ -- so a concurrently-started publisher cannot race ahead of the subscription+ -- and have its events missed. Most callers want 'listen' (no hook); a caller+ -- that forks the listener and then publishes must wait on this hook first.+ ListenWith+ :: m ()+ -- ^ @onSubscribed@ hook to better synchronize on "subscribed".+ -> (UTCTime -> event -> m ())+ -- ^ Listener function to react to events.+ -> Sub event m Void+++makeEffect ''Sub+++-- | Subscribe and deliver every published event to the listener, forever.+-- Defined in terms of 'listenWith' with a no-op subscribed hook.+listen :: (Sub event :> es) => (UTCTime -> event -> Eff es ()) -> Eff es Void+listen = listenWith (pure ())+++-- | Like 'listen', but the listener ignores the event timestamp.+listen_ :: (Sub event :> es) => (event -> Eff es ()) -> Eff es Void+listen_ listener = listen $ \_timestamp event -> listener event+++-- | Like 'listen_', but runs @onSubscribed@ once the subscription is+-- established and before any event is delivered. See 'ListenWith'.+listenWith_ :: (Sub event :> es) => Eff es () -> (event -> Eff es ()) -> Eff es Void+listenWith_ onSubscribed listener = listenWith onSubscribed $ \_timestamp event -> listener event+++-- | Listens until the passed function returns @Just a@, returning said @a@+-- with a timestamp.+listenUntil :: (Sub event :> es) => (UTCTime -> event -> Maybe a) -> Eff es (UTCTime, a)+listenUntil f = do+ res <- runErrorNoCallStack+ $ listen+ $ \timestamp event -> whenJust (f timestamp event) \a -> do+ throwError $ OnceEx (timestamp, a)+ case res of+ Left (OnceEx x) -> pure x+ Right v -> absurd v+++listenUntil_ :: (Sub event :> es) => (event -> Maybe a) -> Eff es a+listenUntil_ f = snd <$> listenUntil (\_ -> f)+++-- | Listens until the passed event handler returns @Just a@, returning said+-- @a@ with a timestamp.+listenUntilM :: (Sub event :> es) => (UTCTime -> event -> Eff es (Maybe a)) -> Eff es (UTCTime, a)+listenUntilM f = do+ res <- runErrorNoCallStack+ $ listen+ $ \timestamp event -> whenJustM (inject $ f timestamp event) \a -> do+ throwError $ OnceEx (timestamp, a)+ case res of+ Left (OnceEx x) -> pure x+ Right v -> absurd v+++-- | Listens until the passed event handler returns @Just a@, returning said+-- @a@.+listenUntilM_ :: (Sub event :> es) => (event -> Eff es (Maybe a)) -> Eff es a+listenUntilM_ f = snd <$> listenUntilM (\_ -> f)+++-- | Fork a background listener and block until it has actually subscribed,+-- then return. The listener runs until the enclosing 'Conc' scope closes.+--+-- This is the safe way to start a listener you intend to publish to: a plain+-- @'fork_' . 'listen'@ followed by a 'publish' races the subscription (which+-- happens asynchronously in the forked thread) and, under scheduler pressure,+-- can drop early events and wedge the listener forever. 'forkListener' closes+-- that window by waiting on the subscribed hook before returning.+forkListener+ :: forall event es+ . (Conc :> es, Concurrent :> es, Sub event :> es)+ => (UTCTime -> event -> Eff es ())+ -> Eff es ()+forkListener listener = do+ subscribed <- atomically newEmptyTMVar+ fork_ $ listenWith (atomically (putTMVar subscribed ())) listener+ atomically (takeTMVar subscribed)+++-- | Like 'forkListener', but the listener ignores the timestamp.+forkListener_+ :: forall event es+ . (Conc :> es, Concurrent :> es, Sub event :> es)+ => (event -> Eff es ())+ -> Eff es ()+forkListener_ listener = forkListener @event (\_timestamp event -> listener event)+++-- | Wait for a single event and then return said event.+listenOnce :: forall event es. (Sub event :> es) => Eff es (UTCTime, event)+listenOnce = do+ res <- runErrorNoCallStack+ $ listen+ $ \timestamp event -> throwError $ OnceEx (timestamp, event)+ case res of+ Left (OnceEx x) -> pure x+ Right v -> absurd v+++-- | Same as 'listenOnce', but discards the timestamp.+listenOnce_ :: (Sub event :> es) => Eff es event+listenOnce_ = snd <$> listenOnce+++data OnceEx ev = OnceEx ev+++instance Show (OnceEx ev) where+ show :: OnceEx ev -> String+ show _ = "OnceEx"
− src/Atelier/Effects/Publishing.hs
@@ -1,39 +0,0 @@-module Atelier.Effects.Publishing- ( runPubSub- )-where--import Data.Time (UTCTime)-import Effectful.Dispatch.Dynamic (interpret, interpret_, localSeqUnlift)--import Atelier.Effects.Chan (Chan)-import Atelier.Effects.Clock (Clock)-import Atelier.Effects.Publishing.Pub (Pub (..))-import Atelier.Effects.Publishing.Sub (Sub (..))--import Atelier.Effects.Chan qualified as Chan-import Atelier.Effects.Clock qualified as Clock----- | Runs 'Pub' and 'Sub' effects with an internal channel for a specific event--- type.-runPubSub- :: forall event es a- . (Chan :> es, Clock :> es)- => Eff (Pub event : Sub event : es) a -> Eff es a-runPubSub action = do- (inChan, _) <- Chan.newChan @(UTCTime, event)- let handlePub = interpret_ \case- Publish event -> do- timestamp <- Clock.currentTime- Chan.writeChan inChan (timestamp, event)-- handleSub = interpret \env -> \case- ListenWith onSubscribed listener -> localSeqUnlift env \unlift -> do- chan <- Chan.dupChan inChan- unlift onSubscribed- forever do- (timestamp, event) <- Chan.readChan chan- unlift $ listener timestamp event-- handleSub . handlePub $ action
− src/Atelier/Effects/Publishing/Pub.hs
@@ -1,57 +0,0 @@-module Atelier.Effects.Publishing.Pub- ( -- * Effect- Pub (..)- , publish-- -- * Interpeters- , runNoOp- , toWriter- , map- , mapM- , consume- ) where--import Effectful (Effect)-import Effectful.Dispatch.Dynamic (interpret_)-import Effectful.TH (makeEffect)-import Effectful.Writer.Static.Shared (Writer, tell)-import Prelude hiding (map, mapM)----- | Effect for publishing events of type @event@.-data Pub (event :: Type) :: Effect where- -- | Publish an event to all current subscribers.- Publish :: event -> Pub event m ()---makeEffect ''Pub---runNoOp :: forall event es a. Eff (Pub event : es) a -> Eff es a-runNoOp = interpret_ \(Publish _) -> pure ()----- | Handler that uses a provided Writer effect instead of actually publishing.--- Useful for testing and inspecting what events were published.-toWriter :: forall event es a. (Writer [event] :> es) => Eff (Pub event : es) a -> Eff es a-toWriter =- interpret_ \case- Publish event -> tell [event]----- | Convert published events of one type into another, utilizing an existing--- effect in the effect stack.-map :: forall e1 e2 es a. (Pub e2 :> es) => (e1 -> e2) -> Eff (Pub e1 : es) a -> Eff es a-map f = interpret_ \(Publish event) -> publish $ f event----- | Convert published events of one type into another with an effectful--- transformation, utilizing an existing effect int he effect stack.-mapM :: forall e1 e2 es a. (Pub e2 :> es) => (e1 -> Eff es e2) -> Eff (Pub e1 : es) a -> Eff es a-mapM f = interpret_ \(Publish event) -> f event >>= publish----- | Perform an effectful action for each published event.-consume :: (event -> Eff es ()) -> Eff (Pub event : es) a -> Eff es a-consume handler = interpret_ \case- Publish event -> handler event
− src/Atelier/Effects/Publishing/Sub.hs
@@ -1,152 +0,0 @@-module Atelier.Effects.Publishing.Sub- ( Sub (..)- , listen- , listen_- , listenWith- , listenWith_- , listenOnce- , listenOnce_- , listenUntil- , listenUntil_- , listenUntilM- , listenUntilM_- , forkListener- , forkListener_- ) where--import Data.Time (UTCTime)-import Effectful (Effect, inject)-import Effectful.Concurrent.STM- ( Concurrent- , atomically- , newEmptyTMVar- , putTMVar- , takeTMVar- )-import Effectful.Error.Static (runErrorNoCallStack, throwError)-import Effectful.TH (makeEffect)--import Text.Show qualified as S--import Atelier.Effects.Conc (Conc, fork_)----- | Effect for subscribing to events of type @event@.-data Sub (event :: Type) :: Effect where- -- | Subscribe, then run @onSubscribed@ once the subscription is established- -- — after the internal channel has been duplicated and before any event is- -- delivered — and thereafter deliver every published event to the listener,- -- forever. The @onSubscribed@ hook lets a caller synchronize on "subscribed"- -- so a concurrently-started publisher cannot race ahead of the subscription- -- and have its events missed. Most callers want 'listen' (no hook); a caller- -- that forks the listener and then publishes must wait on this hook first.- ListenWith- :: m ()- -- ^ @onSubscribed@ hook to better synchronize on "subscribed".- -> (UTCTime -> event -> m ())- -- ^ Listener function to react to events.- -> Sub event m Void---makeEffect ''Sub----- | Subscribe and deliver every published event to the listener, forever.--- Defined in terms of 'listenWith' with a no-op subscribed hook.-listen :: (Sub event :> es) => (UTCTime -> event -> Eff es ()) -> Eff es Void-listen = listenWith (pure ())----- | Like 'listen', but the listener ignores the event timestamp.-listen_ :: (Sub event :> es) => (event -> Eff es ()) -> Eff es Void-listen_ listener = listen $ \_timestamp event -> listener event----- | Like 'listen_', but runs @onSubscribed@ once the subscription is--- established and before any event is delivered. See 'ListenWith'.-listenWith_ :: (Sub event :> es) => Eff es () -> (event -> Eff es ()) -> Eff es Void-listenWith_ onSubscribed listener = listenWith onSubscribed $ \_timestamp event -> listener event----- | Listens until the passed function returns @Just a@, returning said @a@--- with a timestamp.-listenUntil :: (Sub event :> es) => (UTCTime -> event -> Maybe a) -> Eff es (UTCTime, a)-listenUntil f = do- res <- runErrorNoCallStack- $ listen- $ \timestamp event -> whenJust (f timestamp event) \a -> do- throwError $ OnceEx (timestamp, a)- case res of- Left (OnceEx x) -> pure x- Right v -> absurd v---listenUntil_ :: (Sub event :> es) => (event -> Maybe a) -> Eff es a-listenUntil_ f = snd <$> listenUntil (\_ -> f)----- | Listens until the passed event handler returns @Just a@, returning said--- @a@ with a timestamp.-listenUntilM :: (Sub event :> es) => (UTCTime -> event -> Eff es (Maybe a)) -> Eff es (UTCTime, a)-listenUntilM f = do- res <- runErrorNoCallStack- $ listen- $ \timestamp event -> whenJustM (inject $ f timestamp event) \a -> do- throwError $ OnceEx (timestamp, a)- case res of- Left (OnceEx x) -> pure x- Right v -> absurd v----- | Listens until the passed event handler returns @Just a@, returning said--- @a@.-listenUntilM_ :: (Sub event :> es) => (event -> Eff es (Maybe a)) -> Eff es a-listenUntilM_ f = snd <$> listenUntilM (\_ -> f)----- | Fork a background listener and block until it has actually subscribed,--- then return. The listener runs until the enclosing 'Conc' scope closes.------ This is the safe way to start a listener you intend to publish to: a plain--- @'fork_' . 'listen'@ followed by a 'publish' races the subscription (which--- happens asynchronously in the forked thread) and, under scheduler pressure,--- can drop early events and wedge the listener forever. 'forkListener' closes--- that window by waiting on the subscribed hook before returning.-forkListener- :: forall event es- . (Conc :> es, Concurrent :> es, Sub event :> es)- => (UTCTime -> event -> Eff es ())- -> Eff es ()-forkListener listener = do- subscribed <- atomically newEmptyTMVar- fork_ $ listenWith (atomically (putTMVar subscribed ())) listener- atomically (takeTMVar subscribed)----- | Like 'forkListener', but the listener ignores the timestamp.-forkListener_- :: forall event es- . (Conc :> es, Concurrent :> es, Sub event :> es)- => (event -> Eff es ())- -> Eff es ()-forkListener_ listener = forkListener @event (\_timestamp event -> listener event)----- | Wait for a single event and then return said event.-listenOnce :: forall event es. (Sub event :> es) => Eff es (UTCTime, event)-listenOnce = do- res <- runErrorNoCallStack- $ listen- $ \timestamp event -> throwError $ OnceEx (timestamp, event)- case res of- Left (OnceEx x) -> pure x- Right v -> absurd v----- | Same as 'listenOnce', but discards the timestamp.-listenOnce_ :: (Sub event :> es) => Eff es event-listenOnce_ = snd <$> listenOnce---data OnceEx ev = OnceEx ev-instance Show (OnceEx ev) where show _ = "OnceEx"
+ src/Atelier/Effects/Reader.hs view
@@ -0,0 +1,13 @@+module Atelier.Effects.Reader (project) where++import Effectful.Reader.Static (Reader)++import Effectful.Reader.Static qualified as Reader+++-- | Use the value from an existing 'Reader' effect to interpret another+-- 'Reader' effect.+project :: (Reader a :> es) => (a -> b) -> Eff (Reader b : es) x -> Eff es x+project f act = do+ b <- f <$> Reader.ask+ Reader.runReader b act
src/Atelier/Effects/Tally.hs view
@@ -1,39 +1,14 @@ -- | 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- ) where+ , run+ , runConst+ )+where import Effectful (Effect) import Effectful.Concurrent (Concurrent)@@ -41,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@@ -76,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
src/Atelier/Effects/Timeout.hs view
@@ -1,26 +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- ) where+ , 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 @@ -28,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
− src/Atelier/Effects/UUID.hs
@@ -1,37 +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
src/Atelier/Effects/Yield.hs view
@@ -28,7 +28,8 @@ , catMaybes , changes , filter- ) where+ )+where import Effectful.Dispatch.Dynamic (impose_, interpose_) import Effectful.State.Static.Shared (evalState, get)
src/Atelier/Exception.hs view
@@ -11,7 +11,8 @@ , trySyncIO , catchSyncIO , isSyncException- ) where+ )+where import Effectful.Exception (SomeAsyncException, isSyncException) @@ -37,7 +38,8 @@ catchSyncIO :: (HasCallStack) => IO a -> (SomeException -> IO a) -> IO a catchSyncIO f g = f `E.catch` \e ->- if isSyncException e then- g e- else- E.throwIO e+ if isSyncException e+ then+ g e+ else+ E.throwIO e
+ src/Atelier/Signal.hs view
@@ -0,0 +1,35 @@+-- | Termination handler based on Cabal's `Distribution.Client.Signal`.+-- See https://github.com/haskell/cabal/blob/aeb7dbfabad38289cb36da6fdf78acee99b69e3b/cabal-install/src/Distribution/Client/Signal.hs+module Atelier.Signal (installTerminationHandler) where++import Effectful (IOE, withSeqEffToIO)+import Effectful.Concurrent (Concurrent, myThreadId, throwTo)+import Effectful.Exception (asyncExceptionFromException, asyncExceptionToException)+import System.Posix.Signals (Handler (..), installHandler, sigTERM)+import Text.Show (Show (..))+++-- | Terminated is an asynchronous exception, thrown when+-- SIGTERM is received. It's to 'kill' what 'UserInterrupt'+-- is to Ctrl-C.+data Terminated = Terminated+++instance Exception Terminated where+ toException = asyncExceptionToException+ fromException = asyncExceptionFromException+++instance Show Terminated where+ show Terminated = "terminated"+++installTerminationHandler :: (Concurrent :> es, IOE :> es) => Eff es ()+installTerminationHandler = do+ mainThreadId <- myThreadId+ void+ $ withSeqEffToIO \unlift ->+ installHandler+ sigTERM+ (CatchOnce $ unlift $ throwTo mainThreadId Terminated)+ Nothing
src/Atelier/Time.hs view
@@ -1,16 +1,5 @@-{-# OPTIONS_GHC -Wno-orphans #-}- -- | Strongly-typed time units and conversions. ----- Re-exports the duration types from "Data.Time.Units" — so a single import--- covers 'Microsecond', 'Millisecond', 'Second', 'Minute' and 'Hour' — and adds--- conversion helpers plus JSON instances for those types. Each unit serialises--- as an integer count of itself: a 'Second' as a whole number of seconds, a--- 'Millisecond' as milliseconds, and so on.------ Note: the 'FromJSON' and 'ToJSON' instances for the time-unit types are--- orphans, defined here because neither @aeson@ nor @time-units@ provides them.--- -- @ -- nominalDiffTime 1.5 :: Millisecond -- 1.5s rounded to 1500ms -- convertUnit (5 :: Minute) :: Second -- 300@@ -30,11 +19,24 @@ , fromMicroseconds , toMicroseconds , convertUnit- ) where + -- * Utility newtypes for converting time to and from JSON+ , AsJsonMicrosecond (..)+ , AsRawUnit (..)+ )+where+ import Data.Aeson (FromJSON (..), ToJSON (..)) import Data.Time (NominalDiffTime)-import Data.Time.Units (Hour, Microsecond, Millisecond, Minute, Second, TimeUnit, convertUnit, fromMicroseconds, toMicroseconds)+import Data.Time.Units+ ( Hour+ , Microsecond+ , Millisecond+ , Minute+ , Second+ , TimeUnit (..)+ , convertUnit+ ) -- | Convert a 'NominalDiffTime' to any 'TimeUnit', rounding to the nearest@@ -43,44 +45,25 @@ nominalDiffTime = fromMicroseconds . round @Double . (* 1_000_000) . realToFrac --- Orphan instances for JSON deserialization of time unit types.--- All time units in Data.Time.Units wrap Integer, so we parse as Integer.--instance FromJSON Microsecond where- parseJSON = fmap fromInteger . parseJSON---instance FromJSON Millisecond where- parseJSON = fmap fromInteger . parseJSON---instance FromJSON Second where- parseJSON = fmap fromInteger . parseJSON---instance FromJSON Minute where- parseJSON = fmap fromInteger . parseJSON---instance FromJSON Hour where- parseJSON = fmap fromInteger . parseJSON+newtype AsJsonMicrosecond unit = AsJsonMicrosecond {getAsJsonMicroseconds :: unit}+ deriving stock (Eq, Generic, Show) -instance ToJSON Microsecond where- toJSON us = toJSON (toMicroseconds us)+instance (TimeUnit unit) => ToJSON (AsJsonMicrosecond unit) where+ toJSON = toJSON . toMicroseconds . getAsJsonMicroseconds -instance ToJSON Millisecond where- toJSON ms = toJSON (toMicroseconds ms `div` 1000)+instance (TimeUnit unit) => FromJSON (AsJsonMicrosecond unit) where+ parseJSON = fmap (AsJsonMicrosecond . fromMicroseconds) . parseJSON -instance ToJSON Second where- toJSON s = toJSON (toMicroseconds s `div` 1_000_000)+newtype AsRawUnit unit = AsRawUnit {getAsRawUnit :: unit}+ deriving stock (Eq, Generic, Show) -instance ToJSON Minute where- toJSON m = toJSON (toMicroseconds m `div` 60_000_000)+instance (Integral unit) => ToJSON (AsRawUnit unit) where+ toJSON = toJSON . toInteger . getAsRawUnit -instance ToJSON Hour where- toJSON h = toJSON (toMicroseconds h `div` 3_600_000_000)+instance (Integral unit) => FromJSON (AsRawUnit unit) where+ parseJSON = fmap (AsRawUnit . fromInteger) . parseJSON
− src/Atelier/Types/Base64.hs
@@ -1,32 +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)
+ src/Atelier/Types/JSON/Base64.hs view
@@ -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)
+ src/Atelier/Types/JSON/QuietSnake.hs view
@@ -0,0 +1,59 @@+{-# LANGUAGE UndecidableInstances #-}++-- | Derive 'FromJSON' and 'ToJSON' for a record so its Haskell field names map+-- to @quiet_snake_case@ JSON keys.+--+-- \"Quiet\" snake case lowercases and underscore-separates words without an+-- extra leading underscore, so the field @maxRetries@ becomes the JSON key+-- @max_retries@. Derive via this wrapper to keep idiomatic Haskell field names+-- while exposing snake-case JSON:+--+-- @+-- data Settings = Settings { maxRetries :: Int, dryRun :: Bool }+-- deriving stock (Generic)+-- deriving (FromJSON, ToJSON) via (QuietSnake Settings)+-- @+module Atelier.Types.JSON.QuietSnake+ ( QuietSnake (..)+ , options+ )+where++import Data.Aeson+ ( FromJSON (..)+ , GFromJSON+ , GToJSON+ , Options (..)+ , ToJSON (..)+ , Zero+ , camelTo2+ , defaultOptions+ , genericParseJSON+ , genericToJSON+ )+import Data.Default (Default (..))+import GHC.Generics (Rep)+++-- | Carrier for deriving @quiet_snake_case@ JSON instances generically.+newtype QuietSnake a = QuietSnake {getQuietSnake :: a}+++instance (Default a) => Default (QuietSnake a) where+ def = QuietSnake def+++instance (GFromJSON Zero (Rep a), Generic a) => FromJSON (QuietSnake a) where+ parseJSON = fmap QuietSnake . genericParseJSON options+++instance (GToJSON Zero (Rep a), Generic a) => ToJSON (QuietSnake a) where+ toJSON = genericToJSON options . getQuietSnake+++options :: Options+options =+ defaultOptions+ { constructorTagModifier = camelTo2 '_'+ , fieldLabelModifier = camelTo2 '_'+ }
+ src/Atelier/Types/JSON/ReadShow.hs view
@@ -0,0 +1,38 @@+module Atelier.Types.JSON.ReadShow (ReadShow (..)) where++import Data.Aeson (FromJSON (..), ToJSON (..), Value (..), withText)+import Data.Typeable (typeRep)+++-- | Derive 'FromJSON' and 'ToJSON' for a type from its 'Read' and 'Show'+-- instances, encoding each value as a JSON string.+--+-- A value is stored as its 'Show' output and parsed back with 'readMaybe'. On+-- failure the error message names the type (via 'Typeable'), e.g.+-- @Failed to read Mode@.+--+-- @+-- data Mode = Fast | Slow+-- deriving stock (Read, Show)+-- deriving (FromJSON, ToJSON) via (ReadShow Mode)+-- @+--+-- Here @Fast@ serialises to the JSON string @\"Fast\"@.+newtype ReadShow a = ReadShow {getReadShow :: a}+++instance forall a. (Read a, Typeable a) => FromJSON (ReadShow a) where+ parseJSON =+ let+ typeName = show $ typeRep $ Proxy @a+ in+ withText typeName+ $ maybe+ (fail $ "Failed to read " <> typeName)+ (pure . ReadShow)+ . readMaybe+ . toString+++instance (Show a) => ToJSON (ReadShow a) where+ toJSON = String . show . getReadShow
+ src/Atelier/Types/JSON/Renamed.hs view
@@ -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)+ <> "'"
+ src/Atelier/Types/JSON/StringLiteral.hs view
@@ -0,0 +1,29 @@+module Atelier.Types.JSON.StringLiteral (StringLiteral (..)) where++import Data.Aeson (FromJSON (..), ToJSON (..), withText)+import Data.Default (Default (..))+import GHC.TypeLits (KnownSymbol, Symbol, symbolVal)+++-- | Parses and encodes to a specific string literal.+--+-- For parsing, if the parsed JSON value matches the specified string literal,+-- the 'Default' value of the type is returned. All other JSON values are+-- considered invalid.+--+-- This is useful for types consisting of a single nullary constructor that you+-- want to encode as a specific string (that is different from the 'Show' and+-- 'Read' instances of the constructor.)+newtype StringLiteral (literal :: Symbol) a = StringLiteral {getStringLiteral :: a}+++instance forall lit a. (Default a, KnownSymbol lit) => FromJSON (StringLiteral lit a) where+ parseJSON = withText "StringLiteral" \t ->+ if t == toText (symbolVal (Proxy :: Proxy lit))+ then pure $ StringLiteral def+ else fail $ "unexpected value of string. expected " <> symbolVal (Proxy :: Proxy lit)+++instance forall lit a. (KnownSymbol lit) => ToJSON (StringLiteral lit a) where+ toJSON _ = toJSON $ symbolVal (Proxy :: Proxy lit)+ toEncoding _ = toEncoding $ symbolVal (Proxy :: Proxy lit)
+ src/Atelier/Types/JSON/WithDefaults.hs view
@@ -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
− src/Atelier/Types/JsonReadShow.hs
@@ -1,39 +0,0 @@--- | Derive 'FromJSON' and 'ToJSON' for a type from its 'Read' and 'Show'--- instances, encoding each value as a JSON string.------ A value is stored as its 'Show' output and parsed back with 'readMaybe'. On--- failure the error message names the type (via 'Typeable'), e.g.--- @Failed to read Mode@.------ @--- data Mode = Fast | Slow--- deriving stock (Read, Show)--- deriving (FromJSON, ToJSON) via (JsonReadShow Mode)--- @------ Here @Fast@ serialises to the JSON string @\"Fast\"@.-module Atelier.Types.JsonReadShow (JsonReadShow (..)) where--import Data.Aeson (FromJSON (..), ToJSON (..), Value (..), withText)-import Data.Typeable (typeRep)----- | Carrier for deriving JSON instances via 'Read' and 'Show'.-newtype JsonReadShow a = JsonReadShow {getJsonReadShow :: a}---instance forall a. (Read a, Typeable a) => FromJSON (JsonReadShow a) where- parseJSON =- let- typeName = show $ typeRep $ Proxy @a- in- withText typeName- $ maybe- (fail $ "Failed to read " <> typeName)- (pure . JsonReadShow)- . readMaybe- . toString---instance (Show a) => ToJSON (JsonReadShow a) where- toJSON = String . show . getJsonReadShow
− src/Atelier/Types/QuietSnake.hs
@@ -1,44 +0,0 @@-{-# LANGUAGE UndecidableInstances #-}---- | Derive 'FromJSON' and 'ToJSON' for a record so its Haskell field names map--- to @quiet_snake_case@ JSON keys.------ \"Quiet\" snake case lowercases and underscore-separates words without an--- extra leading underscore, so the field @maxRetries@ becomes the JSON key--- @max_retries@. Derive via this wrapper to keep idiomatic Haskell field names--- while exposing snake-case JSON:------ @--- data Settings = Settings { maxRetries :: Int, dryRun :: Bool }--- deriving stock (Generic)--- deriving (FromJSON, ToJSON) via (QuietSnake Settings)--- @-module Atelier.Types.QuietSnake- ( QuietSnake (..)- ) where--import Data.Aeson (FromJSON (..), GFromJSON, GToJSON, Options, ToJSON (..), Zero, genericParseJSON, genericToJSON)-import Data.Aeson.Types (defaultOptions, fieldLabelModifier)-import Data.Default (Default (..))-import GHC.Generics (Rep)-import Text.Casing (quietSnake)----- | Carrier for deriving @quiet_snake_case@ JSON instances generically.-newtype QuietSnake a = QuietSnake {getQuietSnake :: a}---instance (Default a) => Default (QuietSnake a) where- def = QuietSnake def---instance (GFromJSON Zero (Rep a), Generic a) => FromJSON (QuietSnake a) where- parseJSON = fmap QuietSnake . genericParseJSON opts---instance (GToJSON Zero (Rep a), Generic a) => ToJSON (QuietSnake a) where- toJSON = genericToJSON opts . getQuietSnake---opts :: Options-opts = defaultOptions {fieldLabelModifier = quietSnake}
src/Atelier/Types/Semaphore.hs view
@@ -10,7 +10,8 @@ , set , peek , withSemaphore- ) where+ )+where import Effectful.Concurrent.STM (Concurrent, atomically)
src/Atelier/Types/Semaphore/STM.hs view
@@ -9,7 +9,8 @@ , set , peek , withSemaphore- ) where+ )+where import Effectful.Concurrent.STM ( Concurrent
− src/Atelier/Types/WithDefaults.hs
@@ -1,39 +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
test/Unit/Atelier/ConfigSpec.hs view
@@ -1,30 +1,33 @@-module Unit.Atelier.ConfigSpec (spec_Config) where+module Unit.Atelier.ConfigSpec (test_Config) where import Data.Aeson (FromJSON, ToJSON) import Data.Default (Default (..)) import GHC.Generics (Generically (..))-import Test.Hspec (Spec, describe, it, shouldBe)+import Test.Tasty (TestTree, testGroup)+import Test.Tasty.HUnit (testCase, (@?=)) import Data.Aeson qualified as Aeson import Data.Aeson.KeyMap qualified as KM import Atelier.Config (LoadedConfig (..), extractNestedConfig)-import Atelier.Types.QuietSnake (QuietSnake (..))-import Atelier.Types.WithDefaults (WithDefaults (..))+import Atelier.Types.JSON.QuietSnake (QuietSnake (..))+import Atelier.Types.JSON.WithDefaults (WithDefaults (..)) -spec_Config :: Spec-spec_Config = do- describe "extractNestedConfig" testExtractNestedConfig+test_Config :: TestTree+test_Config =+ testGroup+ "Config"+ [ testGroup "extractNestedConfig" testExtractNestedConfig+ ] -testExtractNestedConfig :: Spec-testExtractNestedConfig = do- it "should use default value for non-object Values" do+testExtractNestedConfig :: [TestTree]+testExtractNestedConfig =+ [ testCase "should use default value for non-object Values" do let actual = extractNestedConfig @"foo" $ LoadedConfig $ Aeson.String "foo"- actual `shouldBe` Val "default"-- it "should fetch top-level property" do+ actual @?= Val "default"+ , testCase "should fetch top-level property" do let actual = extractNestedConfig @"foo" $ LoadedConfig@@ -33,16 +36,14 @@ $ Aeson.Object $ KM.singleton "value" $ Aeson.String "actual"- actual `shouldBe` Val "actual"-- it "should return default for a missing key" do+ actual @?= Val "actual"+ , testCase "should return default for a missing key" do let actual = extractNestedConfig @"missing" $ LoadedConfig $ Aeson.Object KM.empty- actual `shouldBe` Val "default"-- it "should fetch a nested property via dot notation" do+ actual @?= Val "default"+ , testCase "should fetch a nested property via dot notation" do let actual = extractNestedConfig @"foo.bar" $ LoadedConfig@@ -53,41 +54,38 @@ $ Aeson.Object $ KM.singleton "value" $ Aeson.String "nested"- actual `shouldBe` Val "nested"-- it "should return default for a missing intermediate segment" do+ actual @?= Val "nested"+ , testCase "should return default for a missing intermediate segment" do let actual = extractNestedConfig @"foo.bar" $ LoadedConfig $ Aeson.Object KM.empty- actual `shouldBe` Val "default"-- it "should return default for a missing leaf segment" do+ actual @?= Val "default"+ , testCase "should return default for a missing leaf segment" do let actual = extractNestedConfig @"foo.bar" $ LoadedConfig $ Aeson.Object $ KM.singleton "foo" $ Aeson.Object KM.empty- actual `shouldBe` Val "default"-- it "should return default when an intermediate value is not an object" do+ actual @?= Val "default"+ , testCase "should return default when an intermediate value is not an object" do let actual = extractNestedConfig @"foo.bar" $ LoadedConfig $ Aeson.Object $ KM.singleton "foo" $ Aeson.String "not-an-object"- actual `shouldBe` Val "default"-- it "should return default when the leaf value fails to decode" do+ actual @?= Val "default"+ , testCase "should return default when the leaf value fails to decode" do let actual = extractNestedConfig @"foo" $ LoadedConfig $ Aeson.Object $ KM.singleton "foo" $ Aeson.String "not-an-object"- actual `shouldBe` Val "default"+ actual @?= Val "default"+ ] data Val = Val {value :: Text}
+ test/Unit/Atelier/Effects/Arguments/SwitchSpec.hs view
@@ -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"+ ]+ ]
test/Unit/Atelier/Effects/AwaitSpec.hs view
@@ -1,96 +1,106 @@-module Unit.Atelier.Effects.AwaitSpec (spec_Await) where+module Unit.Atelier.Effects.AwaitSpec (test_Await) where import Effectful (runEff, runPureEff) import Effectful.Concurrent (runConcurrent) import Effectful.State.Static.Shared (evalState, state) import Effectful.Writer.Static.Shared (runWriter, tell)-import Test.Hspec (Spec, describe, it, shouldBe)+import Test.Tasty (TestTree, testGroup)+import Test.Tasty.HUnit (testCase, (@?=)) +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 -spec_Await :: Spec-spec_Await = do- describe "eachAwait" testEachAwait- describe "takeAwait" testTakeAwait- describe "awaitYield" testAwaitYield+test_Await :: TestTree+test_Await =+ testGroup+ "Await"+ [ testGroup "eachAwait" testEachAwait+ , testGroup "takeAwait" testTakeAwait+ , testGroup "awaitYield" testAwaitYield+ ] -testEachAwait :: Spec-testEachAwait = do- it "answers each await with the given action's result" do+testEachAwait :: [TestTree]+testEachAwait =+ [ testCase "answers each await with the given action's result" do let xs = runPureEff . evalState @Int 0 . Await.eachAwait (state \s -> (s, s + 1)) $ replicateM 4 Await.await- xs `shouldBe` [0, 1, 2, 3]+ xs @?= [0, 1, 2, 3]+ ] -testTakeAwait :: Spec-testTakeAwait = do- it "yields exactly N values from the await stream" do+testTakeAwait :: [TestTree]+testTakeAwait =+ [ testCase "yields exactly N values from the await stream" do let (_, xs) = runPureEff . evalState @Int 0 . Yield.yieldToList . Await.eachAwait @Int (state \s -> (s, s + 1)) $ Await.takeAwait 3- xs `shouldBe` [0, 1, 2]-- describe "when N is zero" $ it "yields nothing" do- let (_, xs) =- runPureEff- . Yield.yieldToList- . Await.eachAwait @Int (pure 7)- $ Await.takeAwait 0- xs `shouldBe` []+ xs @?= [0, 1, 2]+ , testGroup+ "when N is zero"+ [ testCase "yields nothing" do+ let (_, xs) =+ runPureEff+ . Yield.yieldToList+ . Await.eachAwait @Int (pure 7)+ $ Await.takeAwait 0+ xs @?= []+ ]+ ] -testAwaitYield :: Spec-testAwaitYield = do- it "pipes yielded values into the await stream" do+testAwaitYield :: [TestTree]+testAwaitYield =+ [ testCase "pipes yielded values into the await stream" do (_, result) <- runTest $ Await.awaitYield (Yield.inFoldable @Int [1, 2, 3] >> blockForever) $ replicateM 3 Await.await >>= tell - result `shouldBe` [1, 2, 3]-- it "returns the result of the awaiting computation" do+ result @?= [1, 2, 3]+ , testCase "returns the result of the awaiting computation" do -- The yielder blocks after yielding so the awaiter reliably wins the -- termination race and its 'tell' is observed; otherwise the yielder can -- finish first and cancel the awaiter before it writes (flaky under load). (_, result) <- runTest $ Await.awaitYield @Int (Yield.yield 99 >> blockForever)- $ fmap (* 2) Await.await >>= tell . one- result `shouldBe` [198]-- describe "when the awaiter finishes before the yielder"- $ it "terminates with the awaiter's result" do+ $ fmap (* 2) Await.await >>= tell . List.singleton+ result @?= [198]+ , testGroup+ "when the awaiter finishes before the yielder"+ [ testCase "terminates with the awaiter's result" do (result, _) <- runTest . runConcurrent $ do Await.awaitYield @Int (Yield.inFoldable [1 .. 100] >> blockForever) Await.await- result `shouldBe` 1-- describe "when the yielder finishes before the awaiter"- $ it "terminates with the yielder's result" do+ result @?= 1+ ]+ , testGroup+ "when the yielder finishes before the awaiter"+ [ testCase "terminates with the yielder's result" do (result :: Int, _) <- runTest $ Await.awaitYield @Int (Yield.yield 1 >> pure 2) $ Await.await >> Await.await >> pure 1- result `shouldBe` 2+ result @?= 2+ ]+ ] 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.
test/Unit/Atelier/Effects/Cache/SingleflightSpec.hs view
@@ -1,14 +1,21 @@-module Unit.Atelier.Effects.Cache.SingleflightSpec (spec_Singleflight) where+module Unit.Atelier.Effects.Cache.SingleflightSpec (test_Singleflight) where +import Control.Exception (try) import Effectful (IOE, runEff) import Effectful.Concurrent (Concurrent, runConcurrent) import Effectful.Exception (catch, throwIO) import Effectful.State.Static.Shared (State, modify, runState)-import Test.Hspec (Spec, describe, it, shouldBe, shouldThrow)+import 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) @@ -30,10 +37,10 @@ runSingleflightTest action = runEff . runConcurrent- . runConc- . runDelay+ . Conc.runIO+ . Delay.runIO . runState @Int 0- . runSingleflight @Int @Int+ . runIO @Int @Int $ action @@ -52,187 +59,200 @@ pure value -spec_Singleflight :: Spec-spec_Singleflight = do- describe "Basic Behaviors" $ do- describe "First request executes computation" $ do- it "executes the computation on first request" $ do- (result, execCount) <- runSingleflightTest $ do- withCache 1 (compute 42)- result `shouldBe` 42- execCount `shouldBe` 1-- describe "Cached value returned on second request" $ do- it "returns cached value without re-executing" $ do- (result, execCount) <- runSingleflightTest $ do- r1 <- withCache 1 (compute 42)- r2 <- withCache 1 (compute 42)- pure (r1, r2)- result `shouldBe` (42, 42)- execCount `shouldBe` 1-- it "returns cached value across multiple sequential requests" $ do- (results, execCount) <- runSingleflightTest $ do- r1 <- withCache 1 (compute 42)- r2 <- withCache 1 (compute 42)- r3 <- withCache 1 (compute 42)- pure [r1, r2, r3]- results `shouldBe` [42, 42, 42]- execCount `shouldBe` 1-- describe "Concurrent requests are deduplicated" $ do- it "executes computation once for concurrent requests" $ do- (results, execCount) <- runSingleflightTest $ do- -- Launch 10 concurrent requests for the same key- asyncs <- replicateM 10 do+test_Singleflight :: TestTree+test_Singleflight =+ testGroup+ "Singleflight"+ [ testGroup+ "Basic Behaviors"+ [ testGroup+ "First request executes computation"+ [ testCase "executes the computation on first request" $ do+ (result, execCount) <- runSingleflightTest $ do+ with 1 (compute 42)+ result @?= 42+ execCount @?= 1+ ]+ , testGroup+ "Cached value returned on second request"+ [ testCase "returns cached value without re-executing" $ do+ (result, execCount) <- runSingleflightTest $ do+ 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 <- with 1 (compute 42)+ r2 <- with 1 (compute 42)+ r3 <- with 1 (compute 42)+ pure [r1, r2, r3]+ results @?= [42, 42, 42]+ execCount @?= 1+ ]+ , testGroup+ "Concurrent requests are deduplicated"+ [ testCase "executes computation once for concurrent requests" $ do+ (results, execCount) <- runSingleflightTest $ do+ -- Launch 10 concurrent requests for the same key+ asyncs <- replicateM 10 do+ sem <- Sem.new+ async <- Conc.fork $ with 1 (slowCompute sem 42)+ pure (sem, async)+ traverse_ Sem.set $ fst <$> asyncs+ traverse Conc.await $ snd <$> asyncs+ all (== 42) results @?= True+ length results @?= 10+ execCount @?= 1+ , testCase "all concurrent waiters receive the same result" $ do+ (results, execCount) <- runSingleflightTest $ do sem <- Sem.new- async <- Conc.fork $ withCache 1 (slowCompute sem 42)- pure (sem, async)- traverse_ Sem.set $ fst <$> asyncs- traverse Conc.await $ snd <$> asyncs- all (== 42) results `shouldBe` True- length results `shouldBe` 10- execCount `shouldBe` 1-- it "all concurrent waiters receive the same result" $ do- (results, execCount) <- runSingleflightTest $ do- sem <- Sem.new- -- Launch concurrent requests with different delays- a1 <- Conc.fork $ withCache 1 (slowCompute sem 99)- Delay.wait (1 :: Millisecond) -- Ensure first request starts- a2 <- Conc.fork $ withCache 1 (compute 99)- a3 <- Conc.fork $ withCache 1 (compute 99)- Sem.signal sem -- Let first request continue- r1 <- Conc.await a1- r2 <- Conc.await a2- r3 <- Conc.await a3- pure [r1, r2, r3]- results `shouldBe` [99, 99, 99]- execCount `shouldBe` 1-- describe "Different keys execute independently" $ do- it "executes separate computations for different keys" $ do- (results, execCount) <- runSingleflightTest $ do- r1 <- withCache 1 (compute 10)- r2 <- withCache 2 (compute 20)- r3 <- withCache 3 (compute 30)- pure [r1, r2, r3]- results `shouldBe` [10, 20, 30]- execCount `shouldBe` 3-- it "different keys can run concurrently" $ do- (results, execCount) <- runSingleflightTest $ do- sem <- Sem.newSet- a1 <- Conc.fork $ withCache 1 (slowCompute sem 10)- a2 <- Conc.fork $ withCache 2 (slowCompute sem 20)- a3 <- Conc.fork $ withCache 3 (slowCompute sem 30)- replicateM_ 3 $ Sem.signal sem- r1 <- Conc.await a1- r2 <- Conc.await a2- r3 <- Conc.await a3- pure [r1, r2, r3]- all (\r -> r `elem` [10, 20, 30]) results `shouldBe` True- execCount `shouldBe` 3-- describe "UpdateCache pre-populates the cache" $ do- it "returns pre-populated value without executing computation" $ do- (result, execCount) <- runSingleflightTest $ do- updateCache [(1, 99)]- withCache 1 (compute 42)- result `shouldBe` 99- execCount `shouldBe` 0-- it "pre-populated values are returned by subsequent requests" $ do- (results, execCount) <- runSingleflightTest $ do- updateCache [(1, 99)]- r1 <- withCache 1 (compute 42)- r2 <- withCache 1 (compute 42)- pure [r1, r2]- results `shouldBe` [99, 99]- execCount `shouldBe` 0-- describe "UpdateCache handles multiple entries" $ do- it "correctly handles multiple key-value pairs" $ do- (results, execCount) <- runSingleflightTest $ do- updateCache [(1, 10), (2, 20), (3, 30)]- r1 <- withCache 1 (compute 99)- r2 <- withCache 2 (compute 99)- r3 <- withCache 3 (compute 99)- pure [r1, r2, r3]- results `shouldBe` [10, 20, 30]- execCount `shouldBe` 0-- describe "All concurrent waiters receive the result" $ do- it "broadcasts result to all waiting requests" $ do- (results, execCount) <- runSingleflightTest $ do- -- Start one slow computation and many fast waiters- asyncs <- replicateM 20 do+ -- Launch concurrent requests with different delays+ a1 <- Conc.fork $ with 1 (slowCompute sem 99)+ Delay.wait (1 :: Millisecond) -- Ensure first request starts+ 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+ r3 <- Conc.await a3+ pure [r1, r2, r3]+ results @?= [99, 99, 99]+ execCount @?= 1+ ]+ , testGroup+ "Different keys execute independently"+ [ testCase "executes separate computations for different keys" $ do+ (results, execCount) <- runSingleflightTest $ do+ 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 $ 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+ r3 <- Conc.await a3+ pure [r1, r2, r3]+ all (\r -> r `elem` [10, 20, 30]) results @?= True+ execCount @?= 3+ ]+ , testGroup+ "UpdateCache pre-populates the cache"+ [ testCase "returns pre-populated value without executing computation" $ do+ (result, execCount) <- runSingleflightTest $ do+ 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+ update [(1, 99)]+ r1 <- with 1 (compute 42)+ r2 <- with 1 (compute 42)+ pure [r1, r2]+ results @?= [99, 99]+ execCount @?= 0+ ]+ , testGroup+ "UpdateCache handles multiple entries"+ [ testCase "correctly handles multiple key-value pairs" $ do+ (results, execCount) <- runSingleflightTest $ do+ 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+ ]+ , testGroup+ "All concurrent waiters receive the result"+ [ testCase "broadcasts result to all waiting requests" $ do+ (results, execCount) <- runSingleflightTest $ do+ -- Start one slow computation and many fast waiters+ asyncs <- replicateM 20 do+ sem <- Sem.new+ async <- Conc.fork $ with 1 (slowCompute sem 777)+ pure (sem, async)+ traverse_ Sem.signal $ fst <$> asyncs+ traverse Conc.await $ snd <$> asyncs+ all (== 777) results @?= True+ length results @?= 20+ execCount @?= 1+ ]+ ]+ , testGroup+ "Edge Cases"+ [ testGroup+ "Computation throws exception"+ [ testCase "propagates exception to the first caller" $ do+ let action = runSingleflightTest $ do+ 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+ _ <-+ (with @Int @Int 1 (throwIO $ TestException "boom"))+ `catch` \(_ :: TestException) -> pure 0+ -- Second request should re-execute+ 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 $ with @Int @Int 1 (slowCompute sem 42 >> throwIO (TestException "concurrent-boom"))+ Delay.wait (1 :: Millisecond)+ a2 <- Conc.fork $ with @Int @Int 1 (compute 99)+ Sem.signal sem+ _ <- Conc.await a1+ Conc.await a2+ result <- try action+ result @?= Left (TestException "concurrent-boom")+ ]+ , testGroup+ "UpdateCache on in-flight computation"+ [ testCase "overrides result of in-flight computation" $ do+ (result, execCount) <- runSingleflightTest $ do sem <- Sem.new- async <- Conc.fork $ withCache 1 (slowCompute sem 777)- pure (sem, async)- traverse_ Sem.signal $ fst <$> asyncs- traverse Conc.await $ snd <$> asyncs- all (== 777) results `shouldBe` True- length results `shouldBe` 20- execCount `shouldBe` 1-- describe "Edge Cases" $ do- describe "Computation throws exception" $ do- it "propagates exception to the first caller" $ do- let action = runSingleflightTest $ do- withCache @Int @Int 1 (throwIO $ TestException "boom")- action `shouldThrow` (\(TestException msg) -> msg == "boom")-- it "exception does not get cached" $ do- (result, execCount) <- runSingleflightTest $ do- -- First request throws- _ <-- (withCache @Int @Int 1 (throwIO $ TestException "boom"))- `catch` \(_ :: TestException) -> pure 0- -- Second request should re-execute- withCache 1 (compute 42)- result `shouldBe` 42- execCount `shouldBe` 1-- it "propagates exception to all concurrent waiters" $ do- let action = runSingleflightTest $ do+ -- Start slow computation+ a1 <- Conc.fork $ with 1 (slowCompute sem 42)+ Delay.wait (1 :: Millisecond) -- Let it start+ -- Update cache while computation is running+ update [(1, 999)]+ -- Both should get the updated value+ Sem.signal sem+ Conc.await a1+ result @?= 999+ execCount @?= 1+ , testCase "waiting requests receive updated value" $ do+ (results, execCount) <- runSingleflightTest $ do sem <- Sem.new- a1 <- Conc.fork $ withCache @Int @Int 1 (slowCompute sem 42 >> throwIO (TestException "concurrent-boom"))+ -- Start slow computation and waiters+ a1 <- Conc.fork $ with 1 (slowCompute sem 42) Delay.wait (1 :: Millisecond)- a2 <- Conc.fork $ withCache @Int @Int 1 (compute 99)+ a2 <- Conc.fork $ with 1 (compute 42)+ Delay.wait (1 :: Millisecond)+ -- Update while they're all waiting/running+ update [(1, 888)] Sem.signal sem- _ <- Conc.await a1- Conc.await a2- action `shouldThrow` (\(TestException msg) -> msg == "concurrent-boom")-- describe "UpdateCache on in-flight computation" $ do- it "overrides result of in-flight computation" $ do- (result, execCount) <- runSingleflightTest $ do- sem <- Sem.new- -- Start slow computation- a1 <- Conc.fork $ withCache 1 (slowCompute sem 42)- Delay.wait (1 :: Millisecond) -- Let it start- -- Update cache while computation is running- updateCache [(1, 999)]- -- Both should get the updated value- Sem.signal sem- Conc.await a1- result `shouldBe` 999- execCount `shouldBe` 1-- it "waiting requests receive updated value" $ do- (results, execCount) <- runSingleflightTest $ do- sem <- Sem.new- -- Start slow computation and waiters- a1 <- Conc.fork $ withCache 1 (slowCompute sem 42)- Delay.wait (1 :: Millisecond)- a2 <- Conc.fork $ withCache 1 (compute 42)- Delay.wait (1 :: Millisecond)- -- Update while they're all waiting/running- updateCache [(1, 888)]- Sem.signal sem- r1 <- Conc.await a1- r2 <- Conc.await a2- pure [r1, r2]- all (== 888) results `shouldBe` True- execCount `shouldBe` 1+ r1 <- Conc.await a1+ r2 <- Conc.await a2+ pure [r1, r2]+ all (== 888) results @?= True+ execCount @?= 1+ ]+ ]+ ]
test/Unit/Atelier/Effects/CacheSpec.hs view
@@ -1,189 +1,188 @@-module Unit.Atelier.Effects.CacheSpec (spec_Cache) where+module Unit.Atelier.Effects.CacheSpec (test_Cache) where import Data.Time (UTCTime (..), addUTCTime, fromGregorian) import Data.Time.Clock (NominalDiffTime) import Effectful (runEff)-import Effectful.Concurrent (runConcurrent)-import Effectful.Reader.Static (runReader)-import Effectful.State.Static.Shared (evalState, modify)-import Hedgehog (forAll, (===))-import Test.Hspec (Spec, describe, it, shouldBe)-import Test.Hspec.Hedgehog (hedgehog)+import Effectful.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 -spec_Cache :: Spec-spec_Cache = do- describe "Basic Operations" do- it "lookup on absent key returns Nothing" do- result <- runCacheTest $ cacheLookup 1- result `shouldBe` Nothing - it "lookup after insert returns Just value" do- result <- runCacheTest do- cacheInsert 1 42- cacheLookup 1- result `shouldBe` Just 42-- it "lookup after delete returns Nothing" do- result <- runCacheTest $ do- cacheInsert 1 42- cacheDelete 1- cacheLookup 1- result `shouldBe` Nothing-- it "insert twice updates value" do- result <- runCacheTest $ do- cacheInsert 1 42- cacheInsert 1 99- cacheLookup 1- result `shouldBe` Just 99-- it "delete on absent key is a no-op" do- result <- runCacheTest $ do- cacheDelete 1- cacheLookup 1- result `shouldBe` Nothing-- describe "Modify" do- it "modify on absent key uses Nothing branch" do- result <- runCacheTest $ cacheModify @Int @Int 1 (maybe 0 (+ 1))- result `shouldBe` 0-- it "modify on present key uses Just branch" do- result <- runCacheTest $ do- cacheInsert 1 10- cacheModify 1 (maybe 0 (+ 1))- result `shouldBe` 11-- it "modify returns the new value" do- result <- runCacheTest $ do- _ <- cacheModify 1 (maybe 5 (+ 5))- cacheModify 1 (maybe 5 (+ 5))- result `shouldBe` 10-- describe "TTL Eviction" do- it "entry is present before TTL expires" do- result <- runBase . runCacheTestWithWait (STM.atomically STM.retry) $ do- cacheInsert 1 42- cacheLookup 1- result `shouldBe` Just 42-- it "entry is evicted after cleanup thread fires past TTL" do- result <- runBase do- trigger <- STM.atomically STM.newEmptyTMVar- done <- STM.atomically STM.newEmptyTMVar- runCacheTestWithWait (cleanupBarrier done trigger) do- awaitReady done- cacheInsert 1 42- v1 <- cacheLookup 1- modify (addUTCTime (ttl + 1))- stepCleanup trigger done -- run one cleanup, block until it finishes- v2 <- cacheLookup 1- pure (v1, v2)- result `shouldBe` (Just 42, Nothing)-- it "entry within TTL survives cleanup" do- result <- runBase do- trigger <- STM.atomically STM.newEmptyTMVar- done <- STM.atomically STM.newEmptyTMVar- runCacheTestWithWait (cleanupBarrier done trigger) do- awaitReady done- cacheInsert 1 42- modify (addUTCTime (ttl - 1))- stepCleanup trigger done- cacheLookup 1- result `shouldBe` Just 42-- it "re-inserted entry retains original TTL window" do- result <- runBase do- trigger <- STM.atomically STM.newEmptyTMVar- done <- STM.atomically STM.newEmptyTMVar- runCacheTestWithWait (cleanupBarrier done trigger) do- awaitReady done- cacheInsert 1 42- v1 <- cacheLookup 1-- -- re-insert before TTL expires: updates value but preserves createdAt = t0- modify (addUTCTime (ttl - 1))- stepCleanup trigger done- cacheInsert 1 99- v2 <- cacheLookup 1-- -- advance clock past original TTL- modify (addUTCTime 2)- stepCleanup trigger done- v3 <- cacheLookup 1-- pure (v1, v2, v3)- -- createdAt was preserved from the first insert, so the entry is expired and evicted- result `shouldBe` (Just 42, Just 99, Nothing)-- describe "Properties" do- it "insert then lookup roundtrips value" $ hedgehog do- v <- forAll $ Gen.int (Range.linear 0 1000)- result <- liftIO $ runCacheTest $ do- cacheInsert 1 v- cacheLookup 1- result === Just v-- it "distinct keys have independent values" $ hedgehog do- m <- forAll $ Gen.int (Range.linear 1 20)- n <- forAll $ Gen.int (Range.linear 1 20)- (a, b) <- liftIO $ runCacheTest $ do- cacheInsert 1 m- cacheInsert 2 n- va <- cacheLookup 1- vb <- cacheLookup 2- pure (va, vb)- a === Just m- b === Just n+test_Cache :: TestTree+test_Cache =+ testGroup+ "Cache"+ [ testGroup+ "Basic Operations"+ [ testCase "lookup on absent key returns Nothing" do+ result <- runCacheTest $ Cache.lookup 1+ result @?= Nothing+ , testCase "lookup after insert returns Just value" do+ result <- runCacheTest do+ Cache.insert 1 42+ Cache.lookup 1+ result @?= Just 42+ , testCase "lookup after delete returns Nothing" do+ result <- runCacheTest $ do+ Cache.insert 1 42+ Cache.delete 1+ Cache.lookup 1+ result @?= Nothing+ , testCase "insert twice updates value" do+ result <- runCacheTest $ do+ 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+ Cache.delete 1+ Cache.lookup 1+ result @?= Nothing+ ]+ , testGroup+ "Modify"+ [ testCase "modify on absent key uses Nothing branch" do+ result <- runCacheTest $ Cache.modify @Int @Int 1 (maybe 0 (+ 1))+ result @?= 0+ , testCase "modify on present key uses Just branch" do+ result <- runCacheTest $ do+ Cache.insert 1 10+ Cache.modify 1 (maybe 0 (+ 1))+ result @?= 11+ , testCase "modify returns the new value" do+ result <- runCacheTest $ do+ _ <- 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+ Cache.insert 1 42+ Cache.lookup 1+ result @?= Just 42+ , testCase "entry is evicted after cleanup thread fires past TTL" do+ result <- runBase do+ trigger <- STM.atomically STM.newEmptyTMVar+ done <- STM.atomically STM.newEmptyTMVar+ runCacheTestWithWait (cleanupBarrier done trigger) do+ awaitReady done+ Cache.insert 1 42+ v1 <- Cache.lookup 1+ modify (addUTCTime (ttl + 1))+ stepCleanup trigger done -- run one cleanup, block until it finishes+ v2 <- Cache.lookup 1+ pure (v1, v2)+ result @?= (Just 42, Nothing)+ , testCase "entry within TTL survives cleanup" do+ result <- runBase do+ trigger <- STM.atomically STM.newEmptyTMVar+ done <- STM.atomically STM.newEmptyTMVar+ runCacheTestWithWait (cleanupBarrier done trigger) do+ awaitReady done+ Cache.insert 1 42+ modify (addUTCTime (ttl - 1))+ stepCleanup trigger done+ Cache.lookup 1+ result @?= Just 42+ , testCase "re-inserted entry retains original TTL window" do+ result <- runBase do+ trigger <- STM.atomically STM.newEmptyTMVar+ done <- STM.atomically STM.newEmptyTMVar+ runCacheTestWithWait (cleanupBarrier done trigger) do+ awaitReady done+ Cache.insert 1 42+ v1 <- Cache.lookup 1 - it "interleaved key access is independent" $ hedgehog do- keys <- forAll $ Gen.list (Range.linear 1 50) Gen.bool- -- count inserts per key by interleaving- counts <- liftIO $ runCacheTest $ do- let step True = cacheModify @Int 1 (maybe 1 (+ 1))- step False = cacheModify @Int 2 (maybe 1 (+ 1))- traverse step keys- let key1Counts = [c | (k, c) <- zip keys counts, k]- key2Counts = [c | (k, c) <- zip keys counts, not k]- key1Counts === [1 .. length key1Counts]- key2Counts === [1 .. length key2Counts]+ -- re-insert before TTL expires: updates value but preserves createdAt = t0+ modify (addUTCTime (ttl - 1))+ stepCleanup trigger done+ Cache.insert 1 99+ v2 <- Cache.lookup 1 - it "concurrent inserts to different keys don't interfere" $ hedgehog do- n <- forAll $ Gen.int (Range.linear 1 20)- results <- liftIO $ runCacheTest $ do- for_ [1 .. n] \i -> cacheInsert i i- traverse (\i -> cacheLookup i) [1 .. n]- results === map (Just . id) [1 .. n]+ -- advance clock past original TTL+ modify (addUTCTime 2)+ stepCleanup trigger done+ v3 <- Cache.lookup 1 - it "modify is atomic under concurrency" $ hedgehog do- n <- forAll $ Gen.int (Range.linear 1 50)- finalVal <- liftIO $ runCacheTest $ do- for_ [1 .. n] \_ -> cacheModify 1 (maybe 1 (+ 1))- cacheLookup 1- finalVal === Just n+ pure (v1, v2, v3)+ -- createdAt was preserved from the first insert, so the entry is expired and evicted+ result @?= (Just 42, Just 99, Nothing)+ ]+ , testGroup+ "Properties"+ [ testProperty "insert then lookup roundtrips value" $ property do+ v <- forAll $ Gen.int (Range.linear 0 1000)+ result <- liftIO $ runCacheTest $ do+ 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+ 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+ , testProperty "interleaved key access is independent" $ property do+ keys <- forAll $ Gen.list (Range.linear 1 50) Gen.bool+ -- count inserts per key by interleaving+ counts <- liftIO $ runCacheTest $ do+ 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]+ key1Counts === [1 .. length key1Counts]+ key2Counts === [1 .. length key2Counts]+ , 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 -> 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] \_ -> 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
test/Unit/Atelier/Effects/ChanSpec.hs view
@@ -1,80 +1,88 @@-module Unit.Atelier.Effects.ChanSpec (spec_Chan) where+module Unit.Atelier.Effects.ChanSpec (test_Chan) where import Effectful (IOE, runEff) import Effectful.Timeout (Timeout, runTimeout)-import Hedgehog (forAll, (===))-import Test.Hspec (Spec, describe, it, shouldBe)-import Test.Hspec.Hedgehog (hedgehog)+import Hedgehog (forAll, property, (===))+import Test.Tasty (TestTree, testGroup)+import Test.Tasty.HUnit (testCase, (@?=))+import Test.Tasty.Hedgehog (testProperty) 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 -spec_Chan :: Spec-spec_Chan = do- describe "Basic Operations" do- it "writeChan then readChan roundtrips a value" do- result <- runChanTest $ do- (inChan, outChan) <- newChan- writeChan inChan (42 :: Int)- readChan outChan- result `shouldBe` 42 - it "preserves FIFO order" $ hedgehog do- xs <- forAll $ Gen.list (Range.linear 0 50) (Gen.int Range.linearBounded)- result <- liftIO $ runChanTest $ do- (inChan, outChan) <- newChan- traverse_ (writeChan inChan) xs- replicateM (length xs) (readChan outChan)- result === xs-- it "dupChan creates an independent reader that receives the same messages" do- result <- runChanTest $ do- (inChan, outChan1) <- newChan- outChan2 <- dupChan inChan- writeChan inChan (42 :: Int)- v1 <- readChan outChan1- v2 <- readChan outChan2- pure (v1, v2)- result `shouldBe` (42, 42)-- describe "readChanBatched" do- describe "when items fill the batch before timeout" do- it "returns a full batch" do+test_Chan :: TestTree+test_Chan =+ testGroup+ "Chan"+ [ testGroup+ "Basic Operations"+ [ testCase "Chan.write then Chan.read roundtrips a value" do result <- runChanTest $ do- (inChan, outChan) <- newChan- traverse_ (writeChan inChan) [1, 2, 3 :: Int]- readChanBatched (1 :: Second) 3 outChan- result `shouldBe` (1 :| [2, 3])-- it "caps at batchSize even when more items are available" $ hedgehog do- batchSize <- forAll $ Gen.int (Range.linear 1 20)- extra <- forAll $ Gen.int (Range.linear 1 10)- let n = batchSize + extra+ (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) [1 .. n]- readChanBatched (1 :: Second) batchSize outChan- length result === batchSize-- describe "when timeout fires before batch is full" do- it "returns a singleton when only one item is in the channel" do- result <- runChanTest $ do- (inChan, outChan) <- newChan- writeChan inChan (1 :: Int)- readChanBatched (1 :: Millisecond) 5 outChan- result `shouldBe` (1 :| [])-- it "returns a partial batch" do+ (inChan, outChan) <- Chan.new+ traverse_ (Chan.write inChan) xs+ replicateM (length xs) (Chan.read outChan)+ result === xs+ , testCase "Chan.dup creates an independent reader that receives the same messages" do result <- runChanTest $ do- (inChan, outChan) <- newChan- writeChan inChan (1 :: Int)- writeChan inChan 2- readChanBatched (1 :: Millisecond) 5 outChan- result `shouldBe` (1 :| [2])+ (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+ "Chan.readBatched"+ [ testGroup+ "when items fill the batch before timeout"+ [ testCase "returns a full batch" do+ result <- runChanTest $ do+ (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) <- 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) <- 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) <- Chan.new+ Chan.write inChan (1 :: Int)+ Chan.write inChan 2+ Chan.readBatched (1 :: Millisecond) 5 outChan+ result @?= (1 :| [2])+ ]+ ]+ ] --------------------------------------------------------------------------------@@ -82,4 +90,4 @@ -------------------------------------------------------------------------------- runChanTest :: Eff '[Chan, Timeout, IOE] a -> IO a-runChanTest = runEff . runTimeout . runChan+runChanTest = runEff . runTimeout . Chan.run
test/Unit/Atelier/Effects/Conc/TeardownStressSpec.hs view
@@ -13,7 +13,7 @@ -- @ATELIER_CONC_STRESS_N@ (crank it up under @yes@-load to reproduce). Each -- test is wrapped in a 'timeout' so a real teardown hang fails loudly instead -- of wedging the run.-module Unit.Atelier.Effects.Conc.TeardownStressSpec (spec_ConcTeardownStress) where+module Unit.Atelier.Effects.Conc.TeardownStressSpec (test_ConcTeardownStress) where import Control.Concurrent (threadDelay) import Control.Exception (evaluate)@@ -22,83 +22,97 @@ import Effectful.Concurrent.STM (atomically, retry) import System.Environment (lookupEnv) import System.Timeout (timeout)-import Test.Hspec (Spec, describe, it, runIO, shouldBe)+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.Publishing (runPubSub)-import Atelier.Effects.Publishing.Pub (Pub)-import Atelier.Effects.Publishing.Sub (Sub)+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.Publishing.Pub qualified as Pub+import Atelier.Effects.PubSub qualified as PubSub+import Atelier.Effects.PubSub.Pub qualified as Pub -spec_ConcTeardownStress :: Spec-spec_ConcTeardownStress = do- iterations <- runIO (fromMaybe defaultIterations . (>>= readMaybe) <$> lookupEnv "ATELIER_CONC_STRESS_N")- timeoutSecs <- runIO (fromMaybe defaultTimeoutSecs . (>>= readMaybe) <$> lookupEnv "ATELIER_CONC_STRESS_TIMEOUT_S")- runSpin <- runIO (isJust <$> lookupEnv "ATELIER_CONC_SPIN")+test_ConcTeardownStress :: IO TestTree+test_ConcTeardownStress = do+ iterations <-+ fromMaybe defaultIterations . (>>= readMaybe) <$> lookupEnv "ATELIER_CONC_STRESS_N"+ timeoutSecs <-+ fromMaybe defaultTimeoutSecs . (>>= readMaybe) <$> lookupEnv "ATELIER_CONC_STRESS_TIMEOUT_S"+ runSpin <- isJust <$> lookupEnv "ATELIER_CONC_SPIN" - publishDelayUs <- runIO (fromMaybe defaultPublishDelayUs . (>>= readMaybe) <$> lookupEnv "ATELIER_CONC_STRESS_DELAY_US")+ publishDelayUs <-+ fromMaybe defaultPublishDelayUs . (>>= readMaybe) <$> lookupEnv "ATELIER_CONC_STRESS_DELAY_US" let testTimeoutMicros = timeoutSecs * 1_000_000 - describe "Conc.scoped teardown stress" do- it "reaps an STM-blocked fork_ across many scopes" do- completed <-- timeout testTimeoutMicros- $ runConcTest- $ replicateM_ iterations- $ scoped (void (fork_ blockForever))- completed `shouldBe` Just ()-- it "reaps a two-child scope (one parked, one transient) across many scopes" do- completed <-- timeout testTimeoutMicros- $ runConcTest- $ replicateM_ iterations- $ scoped do- _ <- fork (liftIO (threadDelay 5))- void (fork_ blockForever)- completed `shouldBe` Just ()-- -- Faithful repro of the actual full-suite victim: the 'fromEvents' Iterator- -- pattern over its real effect stack, looped. The producer's 10us delay is- -- the ONLY thing giving the forked listener time to subscribe before the- -- first publish; under load that race can drop early events and wedge the- -- consumer's 'Iter.next' (it reads exactly as many as were published, so any- -- dropped event blocks forever). Also exercises the deep-stack- -- 'Conc.scoped' unlift/teardown that the bare tests above strip away.- describe "fromEvents Iterator pattern stress (full stack)" do- it "drives the producer/listener fromEvents scope across many iterations" do- completed <-- timeout testTimeoutMicros- $ runIterTest- $ replicateM_ iterations- $ Iter.fromEvents @Int \iter -> do- _ <- fork do- liftIO (threadDelay publishDelayUs)- traverse_ Pub.publish [1, 2, 3 :: Int]- _ <- replicateM 3 (Iter.next iter)- pure ()- completed `shouldBe` Just ()-- -- A non-allocating fork_ is UN-KILLABLE under -O: -fomit-yields strips the- -- loop's safe point, so the async exception Ki throws at scope close — and- -- the one 'timeout' would throw — can never be delivered. It would wedge an- -- optimized build permanently and burn a core. Hence opt-in, and only safe- -- on a -O0 build (where the boxed-Int loop still allocates and stays- -- killable). This is the discriminating probe for the omit-yields theory.- when runSpin- $ describe "Conc.scoped teardown of a NON-ALLOCATING fork_ (ATELIER_CONC_SPIN=1; -O0 only)" do- it "reaps a non-allocating spin at scope exit" do- completed <-- timeout testTimeoutMicros- $ runConcTest- $ scoped (void (fork_ nonAllocatingSpin))- completed `shouldBe` Just ()+ pure+ $ testGroup "ConcTeardownStress"+ $ [ testGroup+ "Conc.scoped teardown stress"+ [ testCase "reaps an STM-blocked fork_ across many scopes" do+ completed <-+ timeout testTimeoutMicros+ $ runConcTest+ $ replicateM_ iterations+ $ 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+ $ 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+ -- pattern over its real effect stack, looped. The producer's 10us delay is+ -- the ONLY thing giving the forked listener time to subscribe before the+ -- first publish; under load that race can drop early events and wedge the+ -- consumer's 'Iter.next' (it reads exactly as many as were published, so any+ -- dropped event blocks forever). Also exercises the deep-stack+ -- 'Conc.scoped' unlift/teardown that the bare tests above strip away.+ testGroup+ "fromEvents Iterator pattern stress (full stack)"+ [ testCase "drives the producer/listener fromEvents scope across many iterations" do+ completed <-+ timeout testTimeoutMicros+ $ runIterTest+ $ replicateM_ iterations+ $ Iter.fromEvents @Int \iter -> do+ _ <- Conc.fork do+ liftIO (threadDelay publishDelayUs)+ traverse_ Pub.publish [1, 2, 3 :: Int]+ _ <- replicateM 3 (Iter.next iter)+ pure ()+ completed @?= Just ()+ ]+ ]+ -- A non-allocating fork_ is UN-KILLABLE under -O: -fomit-yields strips the+ -- loop's safe point, so the async exception Ki throws at scope close — and+ -- the one 'timeout' would throw — can never be delivered. It would wedge an+ -- optimized build permanently and burn a core. Hence opt-in, and only safe+ -- on a -O0 build (where the boxed-Int loop still allocates and stays+ -- killable). This is the discriminating probe for the omit-yields theory.+ <> [ testGroup+ "Conc.scoped teardown of a NON-ALLOCATING fork_ (ATELIER_CONC_SPIN=1; -O0 only)"+ [ testCase "reaps a non-allocating spin at scope exit" do+ completed <-+ timeout testTimeoutMicros+ $ runConcTest+ $ Conc.scoped (void (Conc.fork_ nonAllocatingSpin))+ completed @?= Just ()+ ]+ | runSpin+ ] where defaultIterations = 300 :: Int defaultTimeoutSecs = 15 :: Int@@ -117,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 . runPubSub @Int+runIterTest = runEff . runConcurrent . Conc.runIO . Clock.runIO . Chan.run . PubSub.run @Int
test/Unit/Atelier/Effects/ConcSpec.hs view
@@ -1,116 +1,128 @@-module Unit.Atelier.Effects.ConcSpec (spec_Conc) where+module Unit.Atelier.Effects.ConcSpec (test_Conc) where -import Control.Exception (ErrorCall (..), throwIO)+import Control.Exception (ErrorCall (..), throwIO, try) import Effectful (IOE, runEff) import Effectful.Concurrent (Concurrent, runConcurrent) import Effectful.Concurrent.STM (atomically, modifyTVar', newTVarIO, readTVar, retry)-import Hedgehog (forAll, (===))-import Test.Hspec (Spec, anyException, context, describe, it, shouldBe, shouldSatisfy, shouldThrow)-import Test.Hspec.Hedgehog (hedgehog)+import Hedgehog (forAll, property, (===))+import Test.Tasty (TestTree, testGroup)+import Test.Tasty.HUnit (assertBool, testCase, (@?=))+import Test.Tasty.Hedgehog (testProperty) import Data.IORef qualified as IORef import Hedgehog.Gen qualified as Gen import Hedgehog.Range qualified as Range -import Atelier.Effects.Conc (Conc, await, awaitAll, fork, forkTry, fork_, runConc, scoped)-import Atelier.Effects.Delay (Delay, runDelay)+import Atelier.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 -spec_Conc :: Spec-spec_Conc = do- describe "Thread cleanup" do- context "without scoped" do- it "demonstrates thread lifetime" $ runTest do- -- This test shows threads live for the duration of their scope- counter <- newTVarIO (0 :: Int)-- -- Thread we fork here will live until the root scope (in- -- 'runTest') exits.- fork_ $ forever $ atomically $ modifyTVar' counter (+ 1)-- let waitFor n = atomically do- v <- readTVar counter- if v >= n then pure v else retry-- countAfter <- waitFor 1- finalCount <- waitFor (countAfter + 1)-- liftIO $ finalCount `shouldSatisfy` (> countAfter)-- context "with scoped" do- it "kills nested threads when scope exits" $ runTest do- counter <- newTVarIO (0 :: Int)-- let waitFor n = atomically do- v <- readTVar counter- if v >= n then pure v else retry+test_Conc :: TestTree+test_Conc =+ testGroup+ "Conc"+ [ testGroup+ "Thread cleanup"+ [ testGroup+ "without scoped"+ [ testCase "demonstrates thread lifetime" $ runTest do+ -- This test shows threads live for the duration of their scope+ counter <- newTVarIO (0 :: Int) - -- Create nested scope that will clean up its threads- scoped do+ -- Thread we fork here will live until the root scope (in+ -- 'runTest') exits. fork_ $ forever $ atomically $ modifyTVar' counter (+ 1)- -- Ensure the thread has incremented at least once- _ <- waitFor 1- pure ()- -- Inner scope exits here - thread should be KILLED - -- Capture count after scope exit- countAfter <- atomically $ readTVar counter-- -- Give any leaked thread a brief window to advance the counter- Delay.wait (1 :: Millisecond)+ let waitFor n = atomically do+ v <- readTVar counter+ if v >= n then pure v else retry - -- Count should NOT increase after scope exit- finalCount <- atomically $ readTVar counter+ countAfter <- waitFor 1+ finalCount <- waitFor (countAfter + 1) - liftIO $ finalCount `shouldBe` countAfter+ liftIO $ assertBool "expected the thread to keep running" $ finalCount > countAfter+ ]+ , testGroup+ "with scoped"+ [ testCase "kills nested threads when scope exits" $ runTest do+ counter <- newTVarIO (0 :: Int) - describe "fork and await" do- it "returns the result of the forked computation" do- result <- runTestSimple $ do- t <- fork $ pure (42 :: Int)- await t- result `shouldBe` 42+ let waitFor n = atomically do+ v <- readTVar counter+ if v >= n then pure v else retry - it "executes the forked action" do- result <- runTestSimple $ do- ref <- liftIO $ IORef.newIORef False- t <- fork $ liftIO $ IORef.writeIORef ref True- await t- liftIO $ IORef.readIORef ref- result `shouldBe` True+ -- Create nested scope that will clean up its threads+ scoped do+ fork_ $ forever $ atomically $ modifyTVar' counter (+ 1)+ -- Ensure the thread has incremented at least once+ _ <- waitFor 1+ pure ()+ -- Inner scope exits here - thread should be KILLED - describe "awaitAll" do- it "waits for all forked threads to complete" $ hedgehog do- n <- forAll $ Gen.int (Range.linear 1 20)- result <- liftIO $ runTestSimple $ do- ref <- liftIO $ IORef.newIORef (0 :: Int)- replicateM_ n $ fork $ liftIO $ IORef.atomicModifyIORef' ref (\x -> (x + 1, ()))- awaitAll- liftIO $ IORef.readIORef ref- result === n+ -- Capture count after scope exit+ countAfter <- atomically $ readTVar counter - describe "forkTry" do- it "returns Right for a successful computation" do- result <- runTestSimple $ do- t <- forkTry @ErrorCall $ pure (42 :: Int)- await t- result `shouldBe` Right 42+ -- Give any leaked thread a brief window to advance the counter+ Delay.wait (1 :: Millisecond) - it "returns Left when the forked thread throws" do- result <- runTestSimple $ do- t <- forkTry @ErrorCall $ liftIO $ throwIO $ ErrorCall "boom"- await t- (result :: Either ErrorCall Int) `shouldSatisfy` isLeft+ -- Count should NOT increase after scope exit+ finalCount <- atomically $ readTVar counter - describe "exception propagation" do- it "uncaught exception in forked thread propagates to the scope" do- let action = runTestSimple $ do- _ <- fork $ liftIO $ throwIO $ ErrorCall "boom"+ liftIO $ finalCount @?= countAfter+ ]+ ]+ , testGroup+ "fork and await"+ [ testCase "returns the result of the forked computation" do+ result <- runTestSimple $ do+ t <- fork $ pure (42 :: Int)+ await t+ result @?= 42+ , testCase "executes the forked action" do+ result <- runTestSimple $ do+ ref <- liftIO $ IORef.newIORef False+ t <- fork $ liftIO $ IORef.writeIORef ref True+ await t+ liftIO $ IORef.readIORef ref+ result @?= True+ ]+ , testGroup+ "awaitAll"+ [ testProperty "waits for all forked threads to complete" $ property do+ n <- forAll $ Gen.int (Range.linear 1 20)+ result <- liftIO $ runTestSimple $ do+ ref <- liftIO $ IORef.newIORef (0 :: Int)+ replicateM_ n $ fork $ liftIO $ IORef.atomicModifyIORef' ref (\x -> (x + 1, ())) awaitAll- action `shouldThrow` anyException+ liftIO $ IORef.readIORef ref+ result === n+ ]+ , testGroup+ "forkTry"+ [ testCase "returns Right for a successful computation" do+ result <- runTestSimple $ do+ t <- forkTry @ErrorCall $ pure (42 :: Int)+ await t+ result @?= Right 42+ , testCase "returns Left when the forked thread throws" do+ result <- runTestSimple $ do+ t <- forkTry @ErrorCall $ liftIO $ throwIO $ ErrorCall "boom"+ await t+ assertBool "expected Left" $ isLeft (result :: Either ErrorCall Int)+ ]+ , testGroup+ "exception propagation"+ [ testCase "uncaught exception in forked thread propagates to the scope" do+ let action = runTestSimple $ do+ _ <- fork $ liftIO $ throwIO $ ErrorCall "boom"+ awaitAll+ result <- try @SomeException action+ isLeft result @?= True+ ]+ ] --------------------------------------------------------------------------------@@ -118,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
test/Unit/Atelier/Effects/ConsoleSpec.hs view
@@ -1,40 +1,48 @@-module Unit.Atelier.Effects.ConsoleSpec (spec_Console) where+module Unit.Atelier.Effects.ConsoleSpec (test_Console) where import Effectful (runPureEff)-import Test.Hspec (Spec, describe, it, shouldBe)+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 -spec_Console :: Spec-spec_Console = do- describe "runConsoleToList" $ do- describe "when nothing is logged" $ it "returns an empty list" $ do- let (_, msgs) = runPureEff $ runConsoleToList $ pure ()- msgs `shouldBe` []-- describe "when logging once" $ it "collects a single traced message" $ do- let (_, msgs) = runPureEff $ runConsoleToList $ Console.putStr "hello"- msgs `shouldBe` ["hello"]-- it "collects multiple logged messages in order" $ do- let (_, msgs) =- runPureEff . runConsoleToList $ do- Console.putStr "first"- Console.putStr "second"- Console.putStr "third"- msgs `shouldBe` ["first", "second", "third"]-- it "returns the result alongside the traced messages" $ do- let (result, msgs) =- runPureEff . runConsoleToList $ do- Console.putStr "side effect"- pure (42 :: Int)- result `shouldBe` 42- msgs `shouldBe` ["side effect"]-- it "traceLn appends a newline to the message" $ do- let (_, msgs) = runPureEff $ runConsoleToList $ Console.putStrLn "line"- msgs `shouldBe` ["line\n"]+test_Console :: TestTree+test_Console =+ testGroup+ "Console"+ [ testGroup+ "runToList"+ [ testGroup+ "when nothing is logged"+ [ testCase "returns an empty list" $ do+ let (_, msgs) = runPureEff $ runToList $ pure ()+ msgs @?= []+ ]+ , testGroup+ "when logging once"+ [ testCase "collects a single traced message" $ do+ let (_, msgs) = runPureEff $ runToList $ Console.putStr "hello"+ msgs @?= ["hello"]+ ]+ , testCase "collects multiple logged messages in order" $ do+ let (_, msgs) =+ 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 . 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 $ runToList $ Console.putStrLn "line"+ msgs @?= ["line\n"]+ ]+ ]
test/Unit/Atelier/Effects/DebounceSpec.hs view
@@ -1,96 +1,95 @@-module Unit.Atelier.Effects.DebounceSpec (spec_Debounce) where+module Unit.Atelier.Effects.DebounceSpec (test_Debounce) where import Data.Dynamic (fromDynamic, toDyn) import Effectful (runEff) import Effectful.Concurrent (runConcurrent)-import Test.Hspec+import Test.Tasty (TestTree, testGroup)+import Test.Tasty.HUnit (assertFailure, testCase, (@?=)) import Data.IORef qualified as IORef import Effectful.Concurrent.STM qualified as STM import StmContainers.Map qualified as Map -import Atelier.Effects.Conc (runConc)-import Atelier.Effects.Debounce- ( Entry (..)- , debounced- , debouncedWith- , ensureCallback- , ensureEntry- , runDebounce- )-import Atelier.Effects.Delay (runDelay)+import Atelier.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 -spec_Debounce :: Spec-spec_Debounce = do- describe "runDebounce" testRunDebounce- describe "ensureEntry" testEnsureEntry- describe "ensureCallback" testEnsureCallback+test_Debounce :: TestTree+test_Debounce =+ testGroup+ "Atelier.Effects.Debounce"+ [ testGroup "run" testRun+ , testGroup "ensureEntry" testEnsureEntry+ , testGroup "ensureCallback" testEnsureCallback+ ] -testEnsureEntry :: Spec-testEnsureEntry = do- describe "new key" do- it "gets generation 0" do+testEnsureEntry :: [TestTree]+testEnsureEntry =+ [ testGroup+ "new key"+ [ testCase "gets generation 0" do state <- runSTM Map.new entry <- runSTM $ mkEntry 1 42 state (+)- entry.generation `shouldBe` 0-- it "stores value as arg" do+ entry.generation @?= 0+ , testCase "stores value as arg" do state <- runSTM Map.new entry <- runSTM $ mkEntry 1 42 state (+)- (entry.arg >>= fromDynamic) `shouldBe` Just @Int 42-- describe "existing key" do- it "increments generation" do+ (entry.arg >>= fromDynamic) @?= Just @Int 42+ ]+ , testGroup+ "existing key"+ [ testCase "increments generation" do state <- runSTM Map.new _ <- runSTM $ mkEntry 1 2 state (+) entry <- runSTM $ mkEntry 1 3 state (+)- entry.generation `shouldBe` 1-- it "applies merge function to old and new value" do+ entry.generation @?= 1+ , testCase "applies merge function to old and new value" do state <- runSTM Map.new _ <- runSTM $ mkEntry 1 5 state (+) entry <- runSTM $ mkEntry 1 10 state (+)- (entry.arg >>= fromDynamic) `shouldBe` Just @Int 15-- describe "multiple updates" do- it "accumulates generation" do+ (entry.arg >>= fromDynamic) @?= Just @Int 15+ ]+ , testGroup+ "multiple updates"+ [ testCase "accumulates generation" do state <- runSTM Map.new _ <- runSTM $ mkEntry 1 1 state (+) _ <- runSTM $ mkEntry 1 2 state (+) entry <- runSTM $ mkEntry 1 3 state (+)- entry.generation `shouldBe` 2-- it "applies merge cumulatively" do+ entry.generation @?= 2+ , testCase "applies merge cumulatively" do state <- runSTM Map.new _ <- runSTM $ mkEntry 1 1 state (+) _ <- runSTM $ mkEntry 1 2 state (+) entry <- runSTM $ mkEntry 1 3 state (+)- (entry.arg >>= fromDynamic) `shouldBe` Just @Int 6-- describe "independent keys" do- it "do not interfere with each other" do+ (entry.arg >>= fromDynamic) @?= Just @Int 6+ ]+ , testGroup+ "independent keys"+ [ testCase "do not interfere with each other" do state <- runSTM Map.new entryA <- runSTM $ mkEntry 1 10 state (+) entryB <- runSTM $ mkEntry 2 20 state (+)- (entryA.arg >>= fromDynamic) `shouldBe` Just @Int 10- (entryB.arg >>= fromDynamic) `shouldBe` Just @Int 20- entryA.generation `shouldBe` 0- entryB.generation `shouldBe` 0+ (entryA.arg >>= fromDynamic) @?= Just @Int 10+ (entryB.arg >>= fromDynamic) @?= Just @Int 20+ entryA.generation @?= 0+ entryB.generation @?= 0+ ]+ ] where mkEntry = ensureEntry @Int @Int runSTM action = runEff . runConcurrent $ STM.atomically action -testEnsureCallback :: Spec-testEnsureCallback = do- it "fires callback when entry's generation still matches" do+testEnsureCallback :: [TestTree]+testEnsureCallback =+ [ testCase "fires callback when entry's generation still matches" do actual <- runCallbackTest do state <- STM.atomically Map.new STM.atomically $ Map.insert (entry 0) (1 :: Int) state@@ -101,27 +100,28 @@ $ liftIO . IORef.writeIORef ref Conc.await t liftIO $ IORef.readIORef ref- actual `shouldBe` 10- it "skips callback when generation has been bumped" do+ actual @?= 10+ , testCase "skips callback when generation has been bumped" do runCallbackTest do state <- STM.atomically Map.new -- A newer event has already bumped generation to 1 STM.atomically $ Map.insert (entry 1) (1 :: Int) state -- This fork was scheduled for generation 0; it should skip ensureCallback @Int @Int 1 state 1 0 \_ ->- liftIO $ False `shouldBe` True- it "skips callback when entry has been removed" do+ liftIO $ False @?= True+ , testCase "skips callback when entry has been removed" do runCallbackTest do state <- STM.atomically Map.new ensureCallback @Int @Int 1 state 1 0 \_ ->- liftIO $ False `shouldBe` True+ liftIO $ False @?= True+ ] where runCallbackTest = runEff . runConcurrent- . Console.runConsole- . Delay.runDelay- . runConc+ . Console.runIO+ . Delay.runIO+ . Conc.runIO entry generation = Entry { generation@@ -135,101 +135,119 @@ -- fires. Multi-burst tests sequence by waiting for each burst's fire, so bursts -- cannot merge regardless of timing. A short grace after the fire guards against -- a spurious second fire.-testRunDebounce :: Spec-testRunDebounce = do- describe "debounced" do- describe "when invoked once" $ it "fires once" do- n <- runTest do- (count, fired) <- newCounter- debounced 50 () (bump count fired)- awaitFire fired- Delay.wait @Millisecond 80- readCount count- n `shouldBe` 1-- describe "when invoked multiple times" $ it "fires once" do- n <- runTest do- (count, fired) <- newCounter- debounced 50 () (bump count fired)- debounced 50 () (bump count fired)- debounced 50 () (bump count fired)- awaitFire fired- Delay.wait @Millisecond 80- readCount count- n `shouldBe` 1-- describe "when invoked multiple times with a delay between" $ it "fires once per burst" do- n <- runTest do- (count, fired) <- newCounter- debounced 50 () (bump count fired)- debounced 50 () (bump count fired)- awaitFire fired -- burst 1 settled and cleared the entry- debounced 50 () (bump count fired)- debounced 50 () (bump count fired)- awaitFire fired -- burst 2 is therefore independent- readCount count- n `shouldBe` 2-- describe "when invoked many times" $ it "should not crash" do- n <- runTest do- (count, fired) <- newCounter- replicateM_ 10_000 $ debounced 50 () (bump count fired)- awaitFire fired- Delay.wait @Millisecond 80- readCount count- n `shouldBe` 1-- describe "debouncedWith" do- describe "when invoked once" $ it "fires callback with the provided arg" do- got <- runTest do- result <- STM.atomically STM.newEmptyTMVar- debouncedWith 50 (+) () (42 :: Int) (signal result)- awaitValue result- got `shouldBe` Just 42-- describe "when invoked multiple times rapidly" do- it "fires once" do+testRun :: [TestTree]+testRun =+ [ testGroup+ "Debounce.with"+ [ testGroup+ "when invoked once"+ [ testCase "fires once" do n <- runTest do (count, fired) <- newCounter+ Debounce.with 50 () (bump count fired)+ awaitFire fired+ Delay.wait @Millisecond 80+ readCount count+ n @?= 1+ ]+ , testGroup+ "when invoked multiple times"+ [ testCase "fires once" do+ n <- runTest do+ (count, fired) <- newCounter+ 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+ n @?= 1+ ]+ , testGroup+ "when invoked multiple times with a delay between"+ [ testCase "fires once per burst" do+ n <- runTest do+ (count, fired) <- newCounter+ Debounce.with 50 () (bump count fired)+ Debounce.with 50 () (bump count fired)+ awaitFire fired -- burst 1 settled and cleared the entry+ Debounce.with 50 () (bump count fired)+ Debounce.with 50 () (bump count fired)+ awaitFire fired -- burst 2 is therefore independent+ readCount count+ n @?= 2+ ]+ , testGroup+ "when invoked many times"+ [ testCase "should not crash" do+ n <- runTest do+ (count, fired) <- newCounter+ replicateM_ 10_000 $ Debounce.with 50 () (bump count fired)+ awaitFire fired+ Delay.wait @Millisecond 80+ readCount count+ n @?= 1+ ]+ ]+ , testGroup+ "Debounce.withArg"+ [ testGroup+ "when invoked once"+ [ testCase "fires callback with the provided arg" do+ got <- runTest do+ result <- STM.atomically STM.newEmptyTMVar+ Debounce.withArg 50 (+) () (42 :: Int) (signal result)+ awaitValue result+ got @?= Just 42+ ]+ , testGroup+ "when invoked multiple times rapidly"+ [ testCase "fires once" do+ n <- runTest do+ (count, fired) <- newCounter let cb _ = bump count fired- debouncedWith 50 (+) () (1 :: Int) cb- debouncedWith 50 (+) () (2 :: Int) cb- debouncedWith 50 (+) () (3 :: Int) cb+ 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- n `shouldBe` 1-- it "fires callback with merged arg" do+ n @?= 1+ , testCase "fires callback with merged arg" do got <- runTest do result <- STM.atomically STM.newEmptyTMVar let cb = signal result- debouncedWith 50 (+) () (1 :: Int) cb- debouncedWith 50 (+) () (2 :: Int) cb- debouncedWith 50 (+) () (3 :: Int) cb+ Debounce.withArg 50 (+) () (1 :: Int) cb+ Debounce.withArg 50 (+) () (2 :: Int) cb+ Debounce.withArg 50 (+) () (3 :: Int) cb awaitValue result- got `shouldBe` Just 6-- describe "when invoked multiple times with a delay between" $ it "fires once per burst with merged arg" do- xs <- runTest do- fired <- STM.atomically STM.newEmptyTMVar- ref <- STM.atomically (STM.newTVar @[Int] [])- let cb v = STM.atomically (STM.modifyTVar' ref (<> [v]) >> void (STM.tryPutTMVar fired ()))- debouncedWith 50 (+) () (1 :: Int) cb- debouncedWith 50 (+) () (2 :: Int) cb- awaitFire fired -- burst 1 fired (1+2=3); entry cleared- debouncedWith 50 (+) () (10 :: Int) cb- debouncedWith 50 (+) () (20 :: Int) cb- awaitFire fired -- burst 2 fired (10+20=30)- STM.atomically (STM.readTVar ref)- xs `shouldBe` [3, 30]+ got @?= Just 6+ ]+ , testGroup+ "when invoked multiple times with a delay between"+ [ testCase "fires once per burst with merged arg" do+ xs <- runTest do+ fired <- STM.atomically STM.newEmptyTMVar+ ref <- STM.atomically (STM.newTVar @[Int] [])+ let cb v = STM.atomically (STM.modifyTVar' ref (<> [v]) >> void (STM.tryPutTMVar fired ()))+ Debounce.withArg 50 (+) () (1 :: Int) cb+ Debounce.withArg 50 (+) () (2 :: Int) cb+ awaitFire fired -- burst 1 fired (1+2=3); entry cleared+ 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]+ ]+ ]+ ] where 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@@ -247,7 +265,7 @@ awaitFire fired = awaitValue fired >>= \case Just () -> pure ()- Nothing -> liftIO $ expectationFailure "debounce callback did not fire within 5s"+ Nothing -> liftIO $ assertFailure "debounce callback did not fire within 5s" awaitValue tmv = either (const Nothing) Just <$> Conc.race (Delay.wait @Millisecond 5000) (STM.atomically (STM.takeTMVar tmv))
test/Unit/Atelier/Effects/FileSystemSpec.hs view
@@ -1,9 +1,10 @@-module Unit.Atelier.Effects.FileSystemSpec (spec_FileSystem) where+module Unit.Atelier.Effects.FileSystemSpec (test_FileSystem) where -import Control.Exception (evaluate)+import Control.Exception (IOException, evaluate, try) import Effectful (runPureEff) import Effectful.State.Static.Shared (State, evalState)-import Test.Hspec (Spec, anyIOException, describe, it, shouldBe, shouldThrow)+import Test.Tasty (TestTree, testGroup)+import Test.Tasty.HUnit (testCase, (@?=)) import Data.ByteString.Lazy qualified as LBS import Data.Map.Strict qualified as M@@ -11,128 +12,133 @@ import Atelier.Effects.FileSystem -spec_FileSystem :: Spec-spec_FileSystem = describe "runFileSystemState" testFileSystemState+test_FileSystem :: TestTree+test_FileSystem =+ testGroup+ "FileSystem"+ [ testGroup "runFileSystemState" testFileSystemState+ ] -testFileSystemState :: Spec-testFileSystemState = do- describe "readFileBs" do- it "reads bytes of a file present in the state" do+testFileSystemState :: [TestTree]+testFileSystemState =+ [ testGroup+ "readFileBs"+ [ testCase "reads bytes of a file present in the state" do run (M.singleton "/a" "hello") (readFileBs "/a")- `shouldBe` "hello"-- it "errors when the file is absent" do- evaluate (run M.empty (readFileBs "/missing"))- `shouldThrow` anyIOException-- describe "readFileLbs" do- it "reads the entire file as lazy bytes" do+ @?= "hello"+ , testCase "errors when the file is absent" do+ result <- try @IOException $ evaluate (run M.empty (readFileBs "/missing"))+ isLeft result @?= True+ ]+ , testGroup+ "readFileLbs"+ [ testCase "reads the entire file as lazy bytes" do run (M.singleton "/a" "hello") (readFileLbs "/a")- `shouldBe` ("hello" :: LBS.ByteString)-- it "errors when the file is absent" do- evaluate (run M.empty (readFileLbs "/missing"))- `shouldThrow` anyIOException-- describe "readFileLbsFrom" do- it "returns full content when offset is 0" do+ @?= ("hello" :: LBS.ByteString)+ , testCase "errors when the file is absent" do+ result <- try @IOException $ evaluate (run M.empty (readFileLbs "/missing"))+ isLeft result @?= True+ ]+ , testGroup+ "readFileLbsFrom"+ [ testCase "returns full content when offset is 0" do run (M.singleton "/a" "hello") (readFileLbsFrom "/a" 0)- `shouldBe` ("hello" :: LBS.ByteString)-- it "skips the leading bytes up to the given offset" do+ @?= ("hello" :: LBS.ByteString)+ , testCase "skips the leading bytes up to the given offset" do run (M.singleton "/a" "hello") (readFileLbsFrom "/a" 2)- `shouldBe` ("llo" :: LBS.ByteString)-- it "returns empty when offset equals the file length" do+ @?= ("llo" :: LBS.ByteString)+ , testCase "returns empty when offset equals the file length" do run (M.singleton "/a" "hello") (readFileLbsFrom "/a" 5)- `shouldBe` ("" :: LBS.ByteString)-- it "errors when the file is absent" do- evaluate (run M.empty (readFileLbsFrom "/missing" 0))- `shouldThrow` anyIOException-- describe "doesFileExist" do- it "returns True for a key present in the state" do+ @?= ("" :: LBS.ByteString)+ , testCase "errors when the file is absent" do+ result <- try @IOException $ evaluate (run M.empty (readFileLbsFrom "/missing" 0))+ isLeft result @?= True+ ]+ , testGroup+ "doesFileExist"+ [ testCase "returns True for a key present in the state" do run (M.singleton "/a" "") (doesFileExist "/a")- `shouldBe` True-- it "returns False when the key is absent" do+ @?= True+ , testCase "returns False when the key is absent" do run M.empty (doesFileExist "/a")- `shouldBe` False-- describe "doesPathExist" do- it "returns True when a key with the path as a string prefix exists" do+ @?= False+ ]+ , testGroup+ "doesPathExist"+ [ testCase "returns True when a key with the path as a string prefix exists" do run (M.singleton "/dir/file" "") (doesPathExist "/dir")- `shouldBe` True-- it "returns False when no key shares the prefix" do+ @?= True+ , testCase "returns False when no key shares the prefix" do run M.empty (doesPathExist "/dir")- `shouldBe` False-- it "returns False for an exact-match key with no children" do+ @?= False+ , testCase "returns False for an exact-match key with no children" do run (M.singleton "/dir" "") (doesPathExist "/dir")- `shouldBe` False-- describe "listDirectory" do- it "returns all keys that start with the given path" do+ @?= False+ ]+ , testGroup+ "listDirectory"+ [ testCase "returns all keys that start with the given path" do let fs = M.fromList [("/dir/a", ""), ("/dir/b", ""), ("/other/c", "")] sort (run fs (listDirectory "/dir"))- `shouldBe` ["/dir/a", "/dir/b"]-- it "returns empty list when no keys share the prefix" do+ @?= ["/dir/a", "/dir/b"]+ , testCase "returns empty list when no keys share the prefix" do run M.empty (listDirectory "/dir")- `shouldBe` []-- it "excludes an exact-match key" do+ @?= []+ , testCase "excludes an exact-match key" do let fs = M.fromList [("/dir", ""), ("/dir/a", "")] run fs (listDirectory "/dir")- `shouldBe` ["/dir/a"]-- describe "removeFile" do- it "removes the file from the state" do+ @?= ["/dir/a"]+ ]+ , testGroup+ "removeFile"+ [ testCase "removes the file from the state" do let result = run (M.singleton "/a" "x") do removeFile "/a" doesFileExist "/a"- result `shouldBe` False-- it "leaves other files unaffected" do+ result @?= False+ , testCase "leaves other files unaffected" do let result = run (M.fromList [("/a", "x"), ("/b", "y")]) do removeFile "/a" doesFileExist "/b"- result `shouldBe` True-- it "is a no-op when the file is absent" do+ result @?= True+ , testCase "is a no-op when the file is absent" do let result = run M.empty do removeFile "/missing" doesFileExist "/missing"- result `shouldBe` False-- describe "createDirectoryIfMissing" do- it "is a no-op — does not add any entries to the state" do+ result @?= False+ ]+ , testGroup+ "createDirectoryIfMissing"+ [ testCase "is a no-op — does not add any entries to the state" do let result = run M.empty do createDirectoryIfMissing True "/new/dir" doesPathExist "/new/dir"- result `shouldBe` False-- describe "canonicalizePath" do- it "returns the path unchanged" do+ result @?= False+ ]+ , testGroup+ "canonicalizePath"+ [ testCase "returns the path unchanged" do run M.empty (canonicalizePath "/some/./path")- `shouldBe` "/some/./path"-- describe "getCurrentDirectory" do- it "returns /" do+ @?= "/some/./path"+ ]+ , testGroup+ "getCurrentDirectory"+ [ testCase "returns /" do run M.empty getCurrentDirectory- `shouldBe` "/"-- describe "getXdgRuntimeDir" do- it "returns /tmp" do+ @?= "/"+ ]+ , testGroup+ "getXdgRuntimeDir"+ [ testCase "returns /tmp" do run M.empty getXdgRuntimeDir- `shouldBe` "/tmp"+ @?= "/tmp"+ ]+ ] run :: Map FilePath ByteString -> Eff '[FileSystem, State (Map FilePath ByteString)] a -> a-run fs = runPureEff . evalState fs . runFileSystemState+run fs = runPureEff . evalState fs . runState
test/Unit/Atelier/Effects/FileWatcherSpec.hs view
@@ -1,83 +1,99 @@-module Unit.Atelier.Effects.FileWatcherSpec (spec_FileWatcher) where+module Unit.Atelier.Effects.FileWatcherSpec (test_FileWatcher) where import Control.Concurrent (forkIO, killThread, newQSem, signalQSem, waitQSem) import Data.IORef (modifyIORef, newIORef, readIORef) import Data.List (isSuffixOf) import Effectful (IOE, runEff) import Effectful.Concurrent (Concurrent, runConcurrent)-import Hedgehog (Gen, PropertyT, forAll, (===))-import Test.Hspec (Spec, describe, it, shouldBe)-import Test.Hspec.Hedgehog (hedgehog)+import Hedgehog (Gen, PropertyT, forAll, property, (===))+import Test.Tasty (TestTree, testGroup)+import Test.Tasty.HUnit (testCase, (@?=))+import Test.Tasty.Hedgehog (testProperty) import Hedgehog.Gen qualified as Gen import Hedgehog.Range qualified as Range -import Atelier.Effects.FileWatcher (FileEvent (..), FileWatcher, Watch, deduplicateDirs, dir, dirWhere, matchesAny, runFileWatcherScripted, watchFilePaths)+import Atelier.Effects.FileWatcher+ ( FileWatcher+ , deduplicateDirs+ , matchesAny+ , 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 -spec_FileWatcher :: Spec-spec_FileWatcher = do- describe "deduplicateDirs" do- describe "properties" do- it "result is an antichain: no element is an ancestor of another"- $ hedgehog propAntichain- it "result covers all inputs: every input has an ancestor-or-equal in the result"- $ hedgehog propCoverage- it "is idempotent"- $ hedgehog propIdempotent- it "result is a subset of the input"- $ hedgehog propSubset - describe "edge cases" do- it "returns empty list unchanged" do- deduplicateDirs [] `shouldBe` []-- it "does not treat a dir as an ancestor of a similarly named dir" do- deduplicateDirs ["/src", "/srcover"] `shouldBe` ["/src", "/srcover"]-- describe "matchesAny" do- it "matches a file under a watched directory" do- matchesAny [dir "/proj/src"] "/proj/src/Foo.hs"- `shouldBe` True-- it "does not match a relative watch dir against an absolute event path" do- -- runFileWatcherIO must canonicalize Watch paths to absolute before- -- calling matchesAny, because fsnotify always reports absolute paths.- matchesAny [dir "src"] "/proj/src/Foo.hs"- `shouldBe` False-- it "applies the file predicate" do- matchesAny [dirWhere "/proj/src" (\f -> ".hs" `isSuffixOf` f)] "/proj/src/Foo.hs"- `shouldBe` True- matchesAny [dirWhere "/proj/src" (\f -> ".hs" `isSuffixOf` f)] "/proj/src/Foo.js"- `shouldBe` False-- describe "runFileWatcherScripted" testScripted+test_FileWatcher :: TestTree+test_FileWatcher =+ testGroup+ "FileWatcher"+ [ testGroup+ "deduplicateDirs"+ [ testGroup+ "properties"+ [ testProperty "result is an antichain: no element is an ancestor of another"+ $ property propAntichain+ , testProperty "result covers all inputs: every input has an ancestor-or-equal in the result"+ $ property propCoverage+ , testProperty "is idempotent"+ $ property propIdempotent+ , testProperty "result is a subset of the input"+ $ property propSubset+ ]+ , testGroup+ "edge cases"+ [ testCase "returns empty list unchanged" do+ deduplicateDirs [] @?= []+ , testCase "does not treat a dir as an ancestor of a similarly named dir" do+ deduplicateDirs ["/src", "/srcover"] @?= ["/src", "/srcover"]+ ]+ ]+ , testGroup+ "matchesAny"+ [ testCase "matches a file under a watched directory" do+ 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 [Watch.dir "src"] "/proj/src/Foo.hs"+ @?= False+ , testCase "applies the file predicate" do+ matchesAny [Watch.dirWhere "/proj/src" (\f -> ".hs" `isSuffixOf` f)] "/proj/src/Foo.hs"+ @?= True+ matchesAny [Watch.dirWhere "/proj/src" (\f -> ".hs" `isSuffixOf` f)] "/proj/src/Foo.js"+ @?= False+ ]+ , testGroup "runFileWatcherScripted" testScripted+ ] -------------------------------------------------------------------------------- -- Scripted interpreter tests -------------------------------------------------------------------------------- -testScripted :: Spec-testScripted = do- describe "watchFilePaths" do- it "calls the callback with the scripted path" do+testScripted :: [TestTree]+testScripted =+ [ testGroup+ "watchFilePaths"+ [ testCase "calls the callback with the scripted path" do paths <- collectPaths ["/src/Foo.hs"]- paths `shouldBe` ["/src/Foo.hs"]-- it "calls the callback with each path in order" do+ paths @?= ["/src/Foo.hs"]+ , testCase "calls the callback with each path in order" do paths <- collectPaths ["/src/Foo.hs", "/src/Bar.hs"]- paths `shouldBe` ["/src/Foo.hs", "/src/Bar.hs"]-- it "ignores the watch specification" do- paths <- collectPathsWith [dir "/any"] ["/src/Foo.hs"]- paths `shouldBe` ["/src/Foo.hs"]-- it "passes the full path to the callback unchanged" do+ paths @?= ["/src/Foo.hs", "/src/Bar.hs"]+ , testCase "ignores the watch specification" do+ 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" paths <- collectPaths [path]- paths `shouldBe` [path]+ paths @?= [path]+ ]+ ] --------------------------------------------------------------------------------@@ -103,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) --------------------------------------------------------------------------------
test/Unit/Atelier/Effects/IteratorSpec.hs view
@@ -1,108 +1,113 @@-module Unit.Atelier.Effects.IteratorSpec (spec_Iterator) where+module Unit.Atelier.Effects.IteratorSpec (test_Iterator) where import Control.Concurrent (threadDelay) import Effectful (IOE, runEff) import Effectful.Concurrent (Concurrent, runConcurrent)-import Test.Hspec (Spec, describe, it, shouldBe)+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.Publishing (runPubSub)-import Atelier.Effects.Publishing.Pub (Pub)-import Atelier.Effects.Publishing.Sub (Sub)+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.Publishing.Pub qualified as Pub+import Atelier.Effects.PubSub qualified as PubSub+import Atelier.Effects.PubSub.Pub qualified as Pub -spec_Iterator :: Spec-spec_Iterator = do- describe "fromEvents" testFromEvents- describe "filter" testFilter- describe "changes" testChanges+test_Iterator :: TestTree+test_Iterator =+ testGroup+ "Iterator"+ [ testGroup "fromEvents" testFromEvents+ , testGroup "filter" testFilter+ , testGroup "changes" testChanges+ ] -testFromEvents :: Spec-testFromEvents = do- it "yields a published event" do+testFromEvents :: [TestTree]+testFromEvents =+ [ 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- result `shouldBe` 42-- it "yields events in publication order" do+ result @?= 42+ , 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)- result `shouldBe` [1, 2, 3]-- it "buffers events so next can catch up" do+ result @?= [1, 2, 3]+ , 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 replicateM 3 (Iter.next iter)- result `shouldBe` [1, 2, 3]+ result @?= [1, 2, 3]+ ] -testFilter :: Spec-testFilter = do- it "passes values that satisfy the predicate" do+testFilter :: [TestTree]+testFilter =+ [ 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)- result `shouldBe` 2-- it "skips values that do not satisfy the predicate" do+ result @?= 2+ , 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))- result `shouldBe` [2, 4, 6]+ result @?= [2, 4, 6]+ ] -testChanges :: Spec-testChanges = do- it "skips values equal to the initial value" do+testChanges :: [TestTree]+testChanges =+ [ 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)- result `shouldBe` 1-- it "yields values that differ from the initial value" do+ result @?= 1+ , 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))- result `shouldBe` [1, 2, 3]-- it "skips initial values interspersed with non-initial values" do+ result @?= [1, 2, 3]+ , 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))- result `shouldBe` [1, 2, 3]+ result @?= [1, 2, 3]+ ] --------------------------------------------------------------------------------@@ -113,7 +118,7 @@ runTest = runEff . runConcurrent- . runConc- . runClock- . runChan- . runPubSub @Int+ . Conc.runIO+ . Clock.runIO+ . Chan.run+ . PubSub.run @Int
test/Unit/Atelier/Effects/LogSpec.hs view
@@ -1,87 +1,94 @@-module Unit.Atelier.Effects.LogSpec (spec_Log) where+module Unit.Atelier.Effects.LogSpec (test_Log) where import Effectful (runPureEff) import Effectful.Writer.Static.Shared (Writer, execWriter)-import Test.Hspec (Spec, describe, it, shouldBe)+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 -spec_Log :: Spec-spec_Log = do- describe "Log with namespace" $ do- it "logs without namespace when not provided" $ do- let logs =- fmap (\m -> (m.namespace, m.text))- . runLogTest- $ info "test message"- logs `shouldBe` [("", "test message")]-- it "prepends a namespace to the logged message" $ do- let logs =- fmap (\m -> (m.namespace, m.text))- . runLogTest- . withNamespace "component"- $ info "test message"- logs `shouldBe` [("component", "test message")]-- describe "nested namespaces" $ do- it "appends a namespace to the current namespace" $ do+test_Log :: TestTree+test_Log =+ testGroup+ "Log"+ [ testGroup+ "Log with namespace"+ [ testCase "logs without namespace when not provided" $ do let logs = fmap (\m -> (m.namespace, m.text)) . runLogTest- . withNamespace "parent"- . withNamespace "child" $ info "test message"- logs `shouldBe` [("parent.child", "test message")]-- it "handles multiple levels of nesting" $ do+ logs @?= [("", "test message")]+ , testCase "prepends a namespace to the logged message" $ do let logs = fmap (\m -> (m.namespace, m.text)) . runLogTest- . withNamespace "level1"- . withNamespace "level2"- . withNamespace "level3"+ . withNamespace "component" $ info "test message"- logs `shouldBe` [("level1.level2.level3", "test message")]-- describe "namespace scoping" $ do- it "only applies namespace within its scope" $ do- let logs =- fmap (\m -> (m.namespace, m.text))- . runPureEff- . execWriter @[Message]- . runLogWriter- $ do- info "before"- withNamespace "scoped" $ info "inside"- info "after"- logs- `shouldBe` [ ("", "before")- , ("scoped", "inside")- , ("", "after")- ]-- it "handles partially nested scopes" $ do- let logs =- fmap (\m -> (m.namespace, m.text))- . runPureEff- . execWriter @[Message]- . runLogWriter- . withNamespace "outer"- $ do- info "outer msg"- withNamespace "inner" $ info "inner msg"- info "outer again"- logs- `shouldBe` [ ("outer", "outer msg")- , ("outer.inner", "inner msg")- , ("outer", "outer again")- ]+ logs @?= [("component", "test message")]+ , testGroup+ "nested namespaces"+ [ testCase "appends a namespace to the current namespace" $ do+ let logs =+ fmap (\m -> (m.namespace, m.text))+ . runLogTest+ . withNamespace "parent"+ . withNamespace "child"+ $ info "test message"+ logs @?= [("parent.child", "test message")]+ , testCase "handles multiple levels of nesting" $ do+ let logs =+ fmap (\m -> (m.namespace, m.text))+ . runLogTest+ . withNamespace "level1"+ . withNamespace "level2"+ . withNamespace "level3"+ $ info "test message"+ logs @?= [("level1.level2.level3", "test message")]+ ]+ , testGroup+ "namespace scoping"+ [ testCase "only applies namespace within its scope" $ do+ let logs =+ fmap (\m -> (m.namespace, m.text))+ . runPureEff+ . execWriter @[Message]+ . Log.runWriter+ $ do+ info "before"+ withNamespace "scoped" $ info "inside"+ info "after"+ logs+ @?= [ ("", "before")+ , ("scoped", "inside")+ , ("", "after")+ ]+ , testCase "handles partially nested scopes" $ do+ let logs =+ fmap (\m -> (m.namespace, m.text))+ . runPureEff+ . execWriter @[Message]+ . Log.runWriter+ . withNamespace "outer"+ $ do+ info "outer msg"+ withNamespace "inner" $ info "inner msg"+ info "outer again"+ logs+ @?= [ ("outer", "outer msg")+ , ("outer.inner", "inner msg")+ , ("outer", "outer again")+ ]+ ]+ ]+ ]
+ test/Unit/Atelier/Effects/PubSub/PubSpec.hs view
@@ -0,0 +1,62 @@+module Unit.Atelier.Effects.PubSub.PubSpec (test_Pub) where++import Effectful (runPureEff)+import Effectful.Writer.Static.Shared (execWriter)+import Test.Tasty (TestTree, testGroup)+import Test.Tasty.HUnit (testCase, (@?=))++import Atelier.Effects.PubSub.Pub qualified as Pub+++data TestEvent = TestEvent Text+ deriving stock (Eq, Show)+++test_Pub :: TestTree+test_Pub =+ testGroup+ "Pub"+ [ testGroup+ "toWriter"+ [ testGroup+ "no events published"+ [ testCase "doesn't record events" do+ let events =+ runPureEff . execWriter . Pub.toWriter @TestEvent+ $ pure ()++ events @?= []+ ]+ , testGroup+ "events published"+ [ testCase "records events" do+ let events =+ runPureEff . execWriter . Pub.toWriter @TestEvent $ do+ Pub.publish $ TestEvent "payload"+ pure ()++ events @?= [TestEvent "payload"]+ ]+ ]+ , testGroup+ "map"+ [ testCase "maps over one event" do+ let events =+ runPureEff+ . execWriter+ . Pub.toWriter @Text+ . Pub.map show+ $ Pub.publish @Int 1++ events @?= ["1"]+ , testCase "maps over many events" do+ let events =+ runPureEff+ . execWriter+ . Pub.toWriter @Text+ . Pub.map show+ $ traverse Pub.publish [1 .. 10 :: Int]++ events @?= ["1", "2", "3", "4", "5", "6", "7", "8", "9", "10"]+ ]+ ]
+ test/Unit/Atelier/Effects/PubSubSpec.hs view
@@ -0,0 +1,92 @@+module Unit.Atelier.Effects.PubSubSpec (test_PubSub) where++import Control.Concurrent.MVar (newEmptyMVar, putMVar, takeMVar)+import Data.Time (UTCTime, getCurrentTime)+import Effectful (IOE, runEff)+import Effectful.Concurrent (Concurrent, runConcurrent)+import Test.Tasty (TestTree, testGroup)+import Test.Tasty.HUnit (testCase, (@?=))++import Atelier.Effects.Chan (Chan)+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+++data TestEvent = TestEvent Text+ deriving stock (Eq, Show)+++test_PubSub :: TestTree+test_PubSub =+ testGroup+ "PubSub"+ [ testGroup+ "run"+ [ testCase "listener receives a published event" do+ result <- runPubSubTest $ do+ received <- liftIO newEmptyMVar+ Sub.forkListener_ @TestEvent \event ->+ liftIO $ putMVar received event+ Pub.publish (TestEvent "hello")+ liftIO $ takeMVar received+ result @?= TestEvent "hello"+ , testCase "event timestamp matches Clock at publish time" do+ t0 <- getCurrentTime+ result <- runPubSubTestWithClock t0 $ do+ received <- liftIO newEmptyMVar+ Sub.forkListener @TestEvent \ts _event ->+ liftIO $ putMVar received ts+ Pub.publish (TestEvent "hello")+ liftIO $ takeMVar received+ result @?= t0+ , testCase "multiple listeners each receive the published event" do+ result <- runPubSubTest $ do+ recv1 <- liftIO newEmptyMVar+ recv2 <- liftIO newEmptyMVar+ Sub.forkListener_ @TestEvent \event -> liftIO $ putMVar recv1 event+ Sub.forkListener_ @TestEvent \event -> liftIO $ putMVar recv2 event+ Pub.publish (TestEvent "hello")+ e1 <- liftIO $ takeMVar recv1+ e2 <- liftIO $ takeMVar recv2+ pure (e1, e2)+ result @?= (TestEvent "hello", TestEvent "hello")+ ]+ ]+++--------------------------------------------------------------------------------+-- Test Helpers+--------------------------------------------------------------------------------++runPubSubTest+ :: Eff '[Pub TestEvent, Sub TestEvent, Chan, Clock, Conc, Concurrent, IOE] a+ -> IO a+runPubSubTest =+ runEff+ . runConcurrent+ . Conc.runIO+ . Clock.runIO+ . Chan.run+ . PubSub.run @TestEvent+++runPubSubTestWithClock+ :: UTCTime+ -> Eff '[Pub TestEvent, Sub TestEvent, Chan, Clock, Conc, Concurrent, IOE] a+ -> IO a+runPubSubTestWithClock t =+ runEff+ . runConcurrent+ . Conc.runIO+ . Clock.runConst t+ . Chan.run+ . PubSub.run @TestEvent
− test/Unit/Atelier/Effects/Publishing/PubSpec.hs
@@ -1,53 +0,0 @@-module Unit.Atelier.Effects.Publishing.PubSpec (spec_Pub) where--import Effectful (runPureEff)-import Effectful.Writer.Static.Shared (execWriter)-import Test.Hspec (Spec, context, describe, it, shouldMatchList)--import Atelier.Effects.Publishing.Pub qualified as Pub---data TestEvent = TestEvent Text- deriving stock (Eq, Show)---spec_Pub :: Spec-spec_Pub = do- describe "toWriter" do- context "no events published" do- it "doesn't record events" do- let events =- runPureEff . execWriter . Pub.toWriter @TestEvent- $ pure ()-- events `shouldMatchList` []-- context "events published" do- it "records events" do- let events =- runPureEff . execWriter . Pub.toWriter @TestEvent $ do- Pub.publish $ TestEvent "payload"- pure ()-- events `shouldMatchList` [TestEvent "payload"]-- describe "map" do- it "maps over one event" do- let events =- runPureEff- . execWriter- . Pub.toWriter @Text- . Pub.map show- $ Pub.publish @Int 1-- events `shouldMatchList` ["1"]-- it "maps over many events" do- let events =- runPureEff- . execWriter- . Pub.toWriter @Text- . Pub.map show- $ traverse Pub.publish [1 .. 10 :: Int]-- events `shouldMatchList` ["1", "2", "3", "4", "5", "6", "7", "8", "9", "10"]
− test/Unit/Atelier/Effects/PublishingSpec.hs
@@ -1,85 +0,0 @@-module Unit.Atelier.Effects.PublishingSpec (spec_Publishing) where--import Control.Concurrent.MVar (newEmptyMVar, putMVar, takeMVar)-import Data.Time (UTCTime, getCurrentTime)-import Effectful (IOE, runEff)-import Effectful.Concurrent (Concurrent, runConcurrent)-import Test.Hspec (Spec, describe, it, shouldBe)--import Atelier.Effects.Chan (Chan, runChan)-import Atelier.Effects.Clock (Clock, runClock, runClockConst)-import Atelier.Effects.Conc (Conc, runConc)-import Atelier.Effects.Publishing (runPubSub)-import Atelier.Effects.Publishing.Pub (Pub)-import Atelier.Effects.Publishing.Sub (Sub)--import Atelier.Effects.Publishing.Pub qualified as Pub-import Atelier.Effects.Publishing.Sub qualified as Sub---data TestEvent = TestEvent Text- deriving stock (Eq, Show)---spec_Publishing :: Spec-spec_Publishing = do- describe "runPubSub" do- it "listener receives a published event" do- result <- runPubSubTest $ do- received <- liftIO newEmptyMVar- Sub.forkListener_ @TestEvent \event ->- liftIO $ putMVar received event- Pub.publish (TestEvent "hello")- liftIO $ takeMVar received- result `shouldBe` TestEvent "hello"-- it "event timestamp matches Clock at publish time" do- t0 <- getCurrentTime- result <- runPubSubTestWithClock t0 $ do- received <- liftIO newEmptyMVar- Sub.forkListener @TestEvent \ts _event ->- liftIO $ putMVar received ts- Pub.publish (TestEvent "hello")- liftIO $ takeMVar received- result `shouldBe` t0-- it "multiple listeners each receive the published event" do- result <- runPubSubTest $ do- recv1 <- liftIO newEmptyMVar- recv2 <- liftIO newEmptyMVar- Sub.forkListener_ @TestEvent \event -> liftIO $ putMVar recv1 event- Sub.forkListener_ @TestEvent \event -> liftIO $ putMVar recv2 event- Pub.publish (TestEvent "hello")- e1 <- liftIO $ takeMVar recv1- e2 <- liftIO $ takeMVar recv2- pure (e1, e2)- result `shouldBe` (TestEvent "hello", TestEvent "hello")-------------------------------------------------------------------------------------- Test Helpers-----------------------------------------------------------------------------------runPubSubTest- :: Eff '[Pub TestEvent, Sub TestEvent, Chan, Clock, Conc, Concurrent, IOE] a- -> IO a-runPubSubTest =- runEff- . runConcurrent- . runConc- . runClock- . runChan- . runPubSub @TestEvent---runPubSubTestWithClock- :: UTCTime- -> Eff '[Pub TestEvent, Sub TestEvent, Chan, Clock, Conc, Concurrent, IOE] a- -> IO a-runPubSubTestWithClock t =- runEff- . runConcurrent- . runConc- . runClockConst t- . runChan- . runPubSub @TestEvent
test/Unit/Atelier/Effects/TallySpec.hs view
@@ -1,79 +1,69 @@-module Unit.Atelier.Effects.TallySpec (spec_Tally) where+module Unit.Atelier.Effects.TallySpec (test_Tally) where import Effectful (IOE, runEff) import Effectful.Concurrent (Concurrent, runConcurrent) import Effectful.Reader.Static (Reader, runReader)-import Hedgehog (forAll, (===))-import Test.Hspec (Spec, describe, it, shouldBe)-import Test.Hspec.Hedgehog (hedgehog)+import Hedgehog (forAll, property, (===))+import Test.Tasty (TestTree, testGroup)+import Test.Tasty.HUnit (testCase, (@?=))+import Test.Tasty.Hedgehog (testProperty) import Data.IORef qualified as IORef import Data.Map.Strict qualified as Map import Hedgehog.Gen qualified as Gen import Hedgehog.Range qualified as Range -import Atelier.Effects.Clock (Clock, runClock)-import Atelier.Effects.Conc (Conc, runConc)-import Atelier.Effects.Delay (Delay, runDelay)-import Atelier.Effects.Log (Log, runLogNoOp)-import Atelier.Effects.Tally (Config (..), Tally, runTally, withTallyCheck)+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 -spec_Tally :: Spec-spec_Tally = do- describe "Multiple Keys" do- it "works with integer keys" do- result <- runTallyTest $ checkCountsForKeys [1, 42, 999 :: Int]- result `shouldBe` Map.fromList [(1, 1), (42, 1), (999, 1)] - describe "Custom Classifiers" do- it "identity classifier returns the raw hit count" do- result <- runTallyTest $ replicateM 4 (withTallyCheck @Int 1 id pure)- result `shouldBe` [1, 2, 3, 4 :: Int]-- it "multi-mark classifier yields correct mark for each hit" do- -- Two thresholds: warning at >2, critical at >4- let classify c- | c > 4 = Just True -- critical- | c > 2 = Just False -- warning- | otherwise = Nothing -- ok- result <- runTallyTest $ replicateM 6 (withTallyCheck @Int 1 classify pure)- result `shouldBe` [Nothing, Nothing, Just False, Just False, Just True, Just True]-- it "classifier producing tuples gives both count and flag" do- let classify c = (c, c > 2)- result <- runTallyTest $ replicateM 4 (withTallyCheck @Int 1 classify pure)- result `shouldBe` [(1, False), (2, False), (3, True), (4, True)]-- describe "Action Execution" do- it "continuation with side effects executes correctly" do- result <- runTallyTest $ do- ref <- liftIO $ IORef.newIORef ([] :: [(Int, Bool)])- replicateM_ 3- $ withTallyCheck @Int 1 (\c -> (c, c > 2))- $ \(count, exceeded) ->- liftIO $ IORef.modifyIORef' ref ((count, exceeded) :)- liftIO $ reverse <$> IORef.readIORef ref- result `shouldBe` [(1, False), (2, False), (3, True)]-- describe "Properties" do- it "kth call receives count k (count fidelity)" $ hedgehog $ do- n <- forAll $ Gen.int (Range.linear 1 100)- results <- liftIO $ runTallyTest $ replicateM n checkCount- results === [1 .. n]-- it "no lost updates under concurrency" $ hedgehog $ do- n <- forAll $ Gen.int (Range.linear 1 50)- finalCount <- liftIO $ runTallyTest $ do- replicateM_ n checkCount- checkCount- finalCount === n + 1-- it "classifier output is passed through unchanged" $ hedgehog $ do- n <- forAll $ Gen.int (Range.linear 1 50)- offset <- forAll $ Gen.int (Range.linear 0 200)- results <- liftIO $ runTallyTest $ replicateM n (withTallyCheck @Int 1 (+ offset) pure)- results === map (+ offset) [1 .. n]+test_Tally :: TestTree+test_Tally =+ testGroup+ "Tally"+ [ testGroup+ "Multiple Keys"+ [ testCase "works with integer keys" do+ result <- runTallyTest $ checkCountsForKeys [1, 42, 999 :: Int]+ result @?= Map.fromList [(1, 1), (42, 1), (999, 1)]+ ]+ , testGroup+ "Action Execution"+ [ testCase "continuation with side effects executes correctly" do+ result <- runTallyTest $ do+ ref <- liftIO $ IORef.newIORef ([] :: [Int])+ replicateM_ 3+ $ Tally.count @Int+ 1+ \count ->+ liftIO $ IORef.modifyIORef' ref (count :)+ liftIO $ reverse <$> IORef.readIORef ref+ result @?= [1, 2, 3]+ ]+ , testGroup+ "Properties"+ [ testProperty "kth call receives count k (count fidelity)" $ property $ do+ n <- forAll $ Gen.int (Range.linear 1 100)+ results <- liftIO $ runTallyTest $ replicateM n checkCount+ results === [1 .. n]+ , testProperty "no lost updates under concurrency" $ property $ do+ n <- forAll $ Gen.int (Range.linear 1 50)+ finalCount <- liftIO $ runTallyTest $ do+ replicateM_ n checkCount+ checkCount+ finalCount === n + 1+ ]+ ] --------------------------------------------------------------------------------@@ -85,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
test/Unit/Atelier/Effects/YieldSpec.hs view
@@ -1,245 +1,254 @@-module Unit.Atelier.Effects.YieldSpec (spec_Yield) where+module Unit.Atelier.Effects.YieldSpec (test_Yield) where import Effectful (runEff, runPureEff) import Effectful.Concurrent (runConcurrent) import Effectful.State.Static.Shared (execState, modify) import Effectful.Writer.Static.Shared (execWriter, tell)-import Test.Hspec (Spec, describe, it, shouldBe, shouldMatchList)--import Atelier.Effects.Chan (runChan)-import Atelier.Effects.Conc (runConc)+import Test.Tasty (TestTree, testGroup)+import Test.Tasty.HUnit (testCase, (@?=)) 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 -spec_Yield :: Spec-spec_Yield = do- describe "yieldToList" testYieldToList- describe "yieldToReverseList" testYieldToReverseList- describe "forEach" testForEach- describe "ignoreYield" testIgnoreYield- describe "inFoldable" testInFoldable- describe "cycleToYield" testCycleToYield- describe "withYieldToList" testWithYieldToList- describe "enumerate" testEnumerate- describe "enumerateFrom" testEnumerateFrom- describe "map" testMap- describe "mapMaybe" testMapMaybe- describe "catMaybes" testCatMaybes- describe "filter" testFilter- describe "changes" testChanges+test_Yield :: TestTree+test_Yield =+ testGroup+ "Yield"+ [ testGroup "yieldToList" testYieldToList+ , testGroup "yieldToReverseList" testYieldToReverseList+ , testGroup "forEach" testForEach+ , testGroup "ignoreYield" testIgnoreYield+ , testGroup "inFoldable" testInFoldable+ , testGroup "cycleToYield" testCycleToYield+ , testGroup "withYieldToList" testWithYieldToList+ , testGroup "enumerate" testEnumerate+ , testGroup "enumerateFrom" testEnumerateFrom+ , testGroup "map" testMap+ , testGroup "mapMaybe" testMapMaybe+ , testGroup "catMaybes" testCatMaybes+ , testGroup "filter" testFilter+ , testGroup "changes" testChanges+ ] -testYieldToList :: Spec-testYieldToList = do- it "collects yields in order" do+testYieldToList :: [TestTree]+testYieldToList =+ [ testCase "collects yields in order" do let ((), xs) = runPureEff $ Yield.yieldToList @Int do Yield.yield 1 Yield.yield 2 Yield.yield 3- xs `shouldMatchList` [1, 2, 3]-- it "returns empty list when nothing is yielded" do+ xs @?= [1, 2, 3]+ , testCase "returns empty list when nothing is yielded" do let (_, xs) = runPureEff $ Yield.yieldToList @Int $ pure ()- xs `shouldMatchList` []-- it "also returns the result of the computation" do+ xs @?= []+ , testCase "also returns the result of the computation" do let (r :: Text, xs) = runPureEff $ Yield.yieldToList do Yield.yield (1 :: Int) pure "result"- r `shouldBe` "result"- xs `shouldMatchList` [1]+ r @?= "result"+ xs @?= [1]+ ] -testYieldToReverseList :: Spec-testYieldToReverseList = do- it "collects yields in reverse order" do+testYieldToReverseList :: [TestTree]+testYieldToReverseList =+ [ testCase "collects yields in reverse order" do let ((), xs) = runPureEff $ Yield.yieldToReverseList @Int do Yield.yield 1 Yield.yield 2 Yield.yield 3- xs `shouldBe` [3, 2, 1]+ xs @?= [3, 2, 1]+ ] -testForEach :: Spec-testForEach = do- it "calls the action for each yielded value" do+testForEach :: [TestTree]+testForEach =+ [ testCase "calls the action for each yielded value" do let xs = runPureEff $ execState @[Int] mempty $ Yield.forEach (\x -> modify (x :)) do Yield.yield 1 Yield.yield 2 Yield.yield 3- xs `shouldBe` [3, 2, 1]-- it "can discard values" do+ xs @?= [3, 2, 1]+ , testCase "can discard values" do let xs = runPureEff $ Yield.forEach @Int (const $ pure ()) do Yield.yield 1- xs `shouldBe` ()+ xs @?= ()+ ] -testIgnoreYield :: Spec-testIgnoreYield = do- it "discards all yielded values" do+testIgnoreYield :: [TestTree]+testIgnoreYield =+ [ testCase "discards all yielded values" do let x = runPureEff $ Yield.ignoreYield @Int do Yield.yield 1 Yield.yield 2- x `shouldBe` ()+ x @?= ()+ ] -testInFoldable :: Spec-testInFoldable = do- it "yields all elements of a list in order" do+testInFoldable :: [TestTree]+testInFoldable =+ [ testCase "yields all elements of a list in order" do let ((), xs) = runPureEff $ Yield.yieldToList $ Yield.inFoldable @Int [1, 2, 3]- xs `shouldBe` [1, 2, 3]-- it "yields nothing for an empty list" do+ xs @?= [1, 2, 3]+ , testCase "yields nothing for an empty list" do let ((), xs) = runPureEff $ Yield.yieldToList $ Yield.inFoldable @Int []- xs `shouldBe` []+ xs @?= []+ ] -testCycleToYield :: Spec-testCycleToYield = do- it "yields elements of a list repeatedly in order" do+testCycleToYield :: [TestTree]+testCycleToYield =+ [ testCase "yields elements of a list repeatedly in order" do xs <- runTest $ Await.awaitYield (Yield.cycleToYield @Int [1, 2, 3]) (replicateM_ 7 (Await.await >>= \x -> tell [x]))- xs `shouldBe` [1, 2, 3, 1, 2, 3, 1]+ xs @?= [1, 2, 3, 1, 2, 3, 1]+ ] where- runTest = runEff . runConcurrent . runConc . runChan . execWriter+ runTest = runEff . runConcurrent . Conc.runIO . Chan.run . execWriter -testWithYieldToList :: Spec-testWithYieldToList = do- it "passes the collected yields to the returned function" do+testWithYieldToList :: [TestTree]+testWithYieldToList =+ [ testCase "passes the collected yields to the returned function" do let result = runPureEff $ Yield.withYieldToList @Int do Yield.yield 1 Yield.yield 2 Yield.yield 3 pure length- result `shouldBe` 3-- it "passes yields in order to the function" do+ result @?= 3+ , testCase "passes yields in order to the function" do let result = runPureEff $ Yield.withYieldToList @Int do Yield.yield 1 Yield.yield 2 Yield.yield 3 pure id- result `shouldBe` [1, 2, 3]-- it "passes an empty list when nothing is yielded" do+ result @?= [1, 2, 3]+ , testCase "passes an empty list when nothing is yielded" do let result = runPureEff $ Yield.withYieldToList @Int do pure null- result `shouldBe` True+ result @?= True+ ] -testEnumerate :: Spec-testEnumerate = do- it "pairs each value with its zero-based index" do+testEnumerate :: [TestTree]+testEnumerate =+ [ testCase "pairs each value with its zero-based index" do let ((), xs) = runPureEff $ Yield.yieldToList $ Yield.enumerate do Yield.yield 'a' Yield.yield 'b' Yield.yield 'c'- xs `shouldBe` [(0, 'a'), (1, 'b'), (2, 'c')]+ xs @?= [(0, 'a'), (1, 'b'), (2, 'c')]+ ] -testEnumerateFrom :: Spec-testEnumerateFrom = do- it "pairs each value with its index starting from the given value" do+testEnumerateFrom :: [TestTree]+testEnumerateFrom =+ [ testCase "pairs each value with its index starting from the given value" do let ((), xs) = runPureEff $ Yield.yieldToList $ Yield.enumerateFrom 5 do Yield.yield 'x' Yield.yield 'y'- xs `shouldBe` [(5, 'x'), (6, 'y')]+ xs @?= [(5, 'x'), (6, 'y')]+ ] -testMap :: Spec-testMap = do- it "transforms each yielded value" do+testMap :: [TestTree]+testMap =+ [ testCase "transforms each yielded value" do let (_, xs) = runPureEff $ Yield.yieldToList $ Yield.map @Int (* 2) do Yield.yield 1 Yield.yield 2 Yield.yield 3- xs `shouldBe` [2, 4, 6]-- it "preserves order" do+ xs @?= [2, 4, 6]+ , testCase "preserves order" do let (_, xs :: [Text]) = runPureEff $ Yield.yieldToList $ Yield.map show do Yield.yield @Int 1 Yield.yield 2- xs `shouldBe` ["1", "2"]+ xs @?= ["1", "2"]+ ] -testMapMaybe :: Spec-testMapMaybe = do- describe "when the function returns Just" $ it "yields transformed values" do- let ((), xs) = runPureEff $ Yield.yieldToList $ Yield.mapMaybe (\x -> if even x then Just (x * 10) else Nothing) do- Yield.yield @Int 1- Yield.yield 2- Yield.yield 3- Yield.yield 4- xs `shouldMatchList` [20, 40]-- describe "when the function always returns Nothing" $ it "yields nothing" do- let (_, xs) = runPureEff $ Yield.yieldToList $ Yield.mapMaybe @Int @Int (const Nothing) do- Yield.yield 1- xs `shouldMatchList` []+testMapMaybe :: [TestTree]+testMapMaybe =+ [ testGroup+ "when the function returns Just"+ [ testCase "yields transformed values" do+ let ((), xs) = runPureEff $ Yield.yieldToList $ Yield.mapMaybe (\x -> if even x then Just (x * 10) else Nothing) do+ Yield.yield @Int 1+ Yield.yield 2+ Yield.yield 3+ Yield.yield 4+ xs @?= [20, 40]+ ]+ , testGroup+ "when the function always returns Nothing"+ [ testCase "yields nothing" do+ let (_, xs) = runPureEff $ Yield.yieldToList $ Yield.mapMaybe @Int @Int (const Nothing) do+ Yield.yield 1+ xs @?= []+ ]+ ] -testCatMaybes :: Spec-testCatMaybes = do- it "unwraps Just values and drops Nothings" do+testCatMaybes :: [TestTree]+testCatMaybes =+ [ testCase "unwraps Just values and drops Nothings" do let (_, xs) = runPureEff $ Yield.yieldToList $ Yield.catMaybes do Yield.yield (Just 1) Yield.yield Nothing Yield.yield (Just 2)- xs `shouldBe` [1 :: Int, 2]-- it "yields nothing when all values are Nothing" do+ xs @?= [1 :: Int, 2]+ , testCase "yields nothing when all values are Nothing" do let (_, xs) = runPureEff $ Yield.yieldToList $ Yield.catMaybes do Yield.yield (Nothing :: Maybe Int) Yield.yield Nothing- xs `shouldBe` []+ xs @?= []+ ] -testFilter :: Spec-testFilter = do- it "passes values satisfying the predicate" do+testFilter :: [TestTree]+testFilter =+ [ testCase "passes values satisfying the predicate" do let (_, xs) = runPureEff $ Yield.yieldToList $ Yield.filter even do Yield.yield 1 Yield.yield 2 Yield.yield 3 Yield.yield 4- xs `shouldBe` [2 :: Int, 4]-- it "drops all values when predicate is always false" do+ xs @?= [2 :: Int, 4]+ , testCase "drops all values when predicate is always false" do let (_, xs) = runPureEff $ Yield.yieldToList $ Yield.filter (const False) do Yield.yield (1 :: Int)- xs `shouldBe` []-- it "passes all values when predicate is always true" do+ xs @?= []+ , testCase "passes all values when predicate is always true" do let (_, xs) = runPureEff $ Yield.yieldToList $ Yield.filter (const True) do Yield.yield 1 Yield.yield 2- xs `shouldBe` [1 :: Int, 2]+ xs @?= [1 :: Int, 2]+ ] -testChanges :: Spec-testChanges = do- it "suppresses yields equal to the initial value" do+testChanges :: [TestTree]+testChanges =+ [ testCase "suppresses yields equal to the initial value" do let (_, xs) = runPureEff $ Yield.yieldToList $ Yield.changes 0 do Yield.yield 0 Yield.yield 1- xs `shouldBe` [1 :: Int]-- it "passes values that differ from the initial value" do+ xs @?= [1 :: Int]+ , testCase "passes values that differ from the initial value" do let (_, xs) = runPureEff $ Yield.yieldToList $ Yield.changes 0 do Yield.yield 1 Yield.yield 2- xs `shouldBe` [1 :: Int, 2]-- it "suppresses initial value interspersed with other values" do+ xs @?= [1 :: Int, 2]+ , testCase "suppresses initial value interspersed with other values" do let (_, xs) = runPureEff $ Yield.yieldToList $ Yield.changes 0 do Yield.yield 0 Yield.yield 1@@ -247,11 +256,11 @@ Yield.yield 2 Yield.yield 0 Yield.yield 3- xs `shouldBe` [1 :: Int, 2, 3]-- it "does not suppress non-initial values even if they repeat" do+ xs @?= [1 :: Int, 2, 3]+ , testCase "does not suppress non-initial values even if they repeat" do let (_, xs) = runPureEff $ Yield.yieldToList $ Yield.changes 0 do Yield.yield 1 Yield.yield 1 Yield.yield 2- xs `shouldBe` [1 :: Int, 1, 2]+ xs @?= [1 :: Int, 1, 2]+ ]
+ test/Unit/Atelier/Types/JSON/WithDefaultsSpec.hs view
@@ -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 = []}+ ]+ ]
test/Unit/Atelier/Types/Semaphore/STMSpec.hs view
@@ -1,10 +1,11 @@-module Unit.Atelier.Types.Semaphore.STMSpec (spec_Semaphore_STM) where+module Unit.Atelier.Types.Semaphore.STMSpec (test_Semaphore_STM) where import Effectful (runEff) import Effectful.Concurrent (runConcurrent) import Effectful.Concurrent.STM (atomically) import Effectful.State.Static.Shared (evalState, get, put)-import Test.Hspec (Spec, describe, it, shouldBe)+import Test.Tasty (TestTree, testGroup)+import Test.Tasty.HUnit (testCase, (@?=)) import Data.IORef qualified as IORef @@ -12,115 +13,136 @@ import Atelier.Types.Semaphore.STM qualified as Sem -spec_Semaphore_STM :: Spec-spec_Semaphore_STM = do- describe "wait" $ it "should halt the computation" do- runEff . runConcurrent . Conc.runConc . evalState @Int 0 $ do- sem <- atomically Sem.new-- thread <- Conc.fork do- atomically $ Sem.wait sem- put 1-- a1 <- get- liftIO $ a1 `shouldBe` 0-- atomically $ Sem.signal sem-- Conc.await thread-- a2 <- get- liftIO $ a2 `shouldBe` 1-- describe "signal" do- it "sets the semaphore" do- result <- runEff . runConcurrent . atomically $ do- sem <- Sem.new- Sem.signal sem- Sem.peek sem- result `shouldBe` True-- describe "clear" do- describe "when the semaphore was set" $ it "returns True" do- result <- runEff . runConcurrent . atomically $ do- sem <- Sem.newSet- Sem.unset sem- result `shouldBe` True-- describe "when the semaphore was not set" $ it "returns False" do- result <- runEff . runConcurrent . atomically $ do- sem <- Sem.new- Sem.unset sem- result `shouldBe` False-- it "leaves the semaphore clear" do- result <- runEff . runConcurrent . atomically $ do- sem <- Sem.newSet- _ <- Sem.unset sem- Sem.peek sem- result `shouldBe` False-- describe "reset" do- describe "when the semaphore was not set" $ it "returns True" do- result <- runEff . runConcurrent . atomically $ do- sem <- Sem.new- Sem.set sem- result `shouldBe` True-- describe "when the semaphore was already set" $ it "returns False" do- result <- runEff . runConcurrent . atomically $ do- sem <- Sem.newSet- Sem.set sem- result `shouldBe` False-- it "leaves the semaphore set" do- result <- runEff . runConcurrent . atomically $ do- sem <- Sem.new- _ <- Sem.set sem- Sem.peek sem- result `shouldBe` True-- describe "peek" do- describe "when the semaphore is set" $ it "returns True" do- result <- runEff . runConcurrent . atomically $ do- sem <- Sem.newSet- Sem.peek sem- result `shouldBe` True+test_Semaphore_STM :: TestTree+test_Semaphore_STM =+ testGroup+ "Semaphore.STM"+ [ testGroup+ "wait"+ [ testCase "should halt the computation" do+ runEff . runConcurrent . Conc.runIO . evalState @Int 0 $ do+ sem <- atomically Sem.new - describe "when the semaphore is not set" $ it "returns False" do- result <- runEff . runConcurrent . atomically $ do- sem <- Sem.new- Sem.peek sem- result `shouldBe` False+ thread <- Conc.fork do+ atomically $ Sem.wait sem+ put 1 - it "does not change the state of the semaphore" do- (before, after) <- runEff . runConcurrent . atomically $ do- sem <- Sem.newSet- before <- Sem.peek sem- after <- Sem.peek sem- pure (before, after)- (before, after) `shouldBe` (True, True)+ a1 <- get+ liftIO $ a1 @?= 0 - describe "withSemaphore" do- it "returns the result of the enclosed computation" do- result <- runEff . runConcurrent $ do- sem <- atomically Sem.newSet- Sem.withSemaphore sem $ pure (42 :: Int)- result `shouldBe` 42+ atomically $ Sem.signal sem - it "signals the semaphore after the computation" do- result <- runEff . runConcurrent $ do- sem <- atomically Sem.newSet- Sem.withSemaphore sem $ pure ()- atomically $ Sem.peek sem- result `shouldBe` True+ Conc.await thread - it "waits for the semaphore before running" do- result <- runEff . runConcurrent . Conc.runConc $ do- sem <- atomically Sem.new- ref <- liftIO $ IORef.newIORef False- _ <- Conc.fork $ do- liftIO $ IORef.writeIORef ref True- atomically $ Sem.signal sem- Sem.withSemaphore sem $ liftIO $ IORef.readIORef ref- result `shouldBe` True+ a2 <- get+ liftIO $ a2 @?= 1+ ]+ , testGroup+ "signal"+ [ testCase "sets the semaphore" do+ result <- runEff . runConcurrent . atomically $ do+ sem <- Sem.new+ Sem.signal sem+ Sem.peek sem+ result @?= True+ ]+ , testGroup+ "clear"+ [ testGroup+ "when the semaphore was set"+ [ testCase "returns True" do+ result <- runEff . runConcurrent . atomically $ do+ sem <- Sem.newSet+ Sem.unset sem+ result @?= True+ ]+ , testGroup+ "when the semaphore was not set"+ [ testCase "returns False" do+ result <- runEff . runConcurrent . atomically $ do+ sem <- Sem.new+ Sem.unset sem+ result @?= False+ ]+ , testCase "leaves the semaphore clear" do+ result <- runEff . runConcurrent . atomically $ do+ sem <- Sem.newSet+ _ <- Sem.unset sem+ Sem.peek sem+ result @?= False+ ]+ , testGroup+ "reset"+ [ testGroup+ "when the semaphore was not set"+ [ testCase "returns True" do+ result <- runEff . runConcurrent . atomically $ do+ sem <- Sem.new+ Sem.set sem+ result @?= True+ ]+ , testGroup+ "when the semaphore was already set"+ [ testCase "returns False" do+ result <- runEff . runConcurrent . atomically $ do+ sem <- Sem.newSet+ Sem.set sem+ result @?= False+ ]+ , testCase "leaves the semaphore set" do+ result <- runEff . runConcurrent . atomically $ do+ sem <- Sem.new+ _ <- Sem.set sem+ Sem.peek sem+ result @?= True+ ]+ , testGroup+ "peek"+ [ testGroup+ "when the semaphore is set"+ [ testCase "returns True" do+ result <- runEff . runConcurrent . atomically $ do+ sem <- Sem.newSet+ Sem.peek sem+ result @?= True+ ]+ , testGroup+ "when the semaphore is not set"+ [ testCase "returns False" do+ result <- runEff . runConcurrent . atomically $ do+ sem <- Sem.new+ Sem.peek sem+ result @?= False+ ]+ , testCase "does not change the state of the semaphore" do+ (before, after) <- runEff . runConcurrent . atomically $ do+ sem <- Sem.newSet+ before <- Sem.peek sem+ after <- Sem.peek sem+ pure (before, after)+ (before, after) @?= (True, True)+ ]+ , testGroup+ "withSemaphore"+ [ testCase "returns the result of the enclosed computation" do+ result <- runEff . runConcurrent $ do+ sem <- atomically Sem.newSet+ Sem.withSemaphore sem $ pure (42 :: Int)+ result @?= 42+ , testCase "signals the semaphore after the computation" do+ result <- runEff . runConcurrent $ do+ sem <- atomically Sem.newSet+ Sem.withSemaphore sem $ pure ()+ atomically $ Sem.peek sem+ result @?= True+ , testCase "waits for the semaphore before running" do+ result <- runEff . runConcurrent . Conc.runIO $ do+ sem <- atomically Sem.new+ ref <- liftIO $ IORef.newIORef False+ _ <- Conc.fork $ do+ liftIO $ IORef.writeIORef ref True+ atomically $ Sem.signal sem+ Sem.withSemaphore sem $ liftIO $ IORef.readIORef ref+ result @?= True+ ]+ ]
test/Unit/Atelier/Types/SemaphoreSpec.hs view
@@ -1,9 +1,10 @@-module Unit.Atelier.Types.SemaphoreSpec (spec_Semaphore) where+module Unit.Atelier.Types.SemaphoreSpec (test_Semaphore) where import Effectful (runEff) import Effectful.Concurrent (runConcurrent) import Effectful.State.Static.Shared (evalState, get, put)-import Test.Hspec (Spec, describe, it, shouldBe)+import Test.Tasty (TestTree, testGroup)+import Test.Tasty.HUnit (testCase, (@?=)) import Data.IORef qualified as IORef @@ -11,115 +12,136 @@ import Atelier.Types.Semaphore qualified as Sem -spec_Semaphore :: Spec-spec_Semaphore = do- describe "wait" $ it "should halt the computation" do- runEff . runConcurrent . Conc.runConc . evalState @Int 0 $ do- sem <- Sem.new-- thread <- Conc.fork do- Sem.wait sem- put 1-- a1 <- get- liftIO $ a1 `shouldBe` 0-- Sem.signal sem-- Conc.await thread-- a2 <- get- liftIO $ a2 `shouldBe` 1-- describe "signal" do- it "sets the semaphore" do- result <- runEff . runConcurrent $ do- sem <- Sem.new- Sem.signal sem- Sem.peek sem- result `shouldBe` True-- describe "clear" do- describe "when the semaphore was set" $ it "returns True" do- result <- runEff . runConcurrent $ do- sem <- Sem.newSet- Sem.unset sem- result `shouldBe` True-- describe "when the semaphore was not set" $ it "returns False" do- result <- runEff . runConcurrent $ do- sem <- Sem.new- Sem.unset sem- result `shouldBe` False-- it "leaves the semaphore clear" do- result <- runEff . runConcurrent $ do- sem <- Sem.newSet- _ <- Sem.unset sem- Sem.peek sem- result `shouldBe` False-- describe "reset" do- describe "when the semaphore was not set" $ it "returns True" do- result <- runEff . runConcurrent $ do- sem <- Sem.new- Sem.set sem- result `shouldBe` True-- describe "when the semaphore was already set" $ it "returns False" do- result <- runEff . runConcurrent $ do- sem <- Sem.newSet- Sem.set sem- result `shouldBe` False-- it "leaves the semaphore set" do- result <- runEff . runConcurrent $ do- sem <- Sem.new- _ <- Sem.set sem- Sem.peek sem- result `shouldBe` True-- describe "peek" do- describe "when the semaphore is set" $ it "returns True" do- result <- runEff . runConcurrent $ do- sem <- Sem.newSet- Sem.peek sem- result `shouldBe` True+test_Semaphore :: TestTree+test_Semaphore =+ testGroup+ "Semaphore"+ [ testGroup+ "wait"+ [ testCase "should halt the computation" do+ runEff . runConcurrent . Conc.runIO . evalState @Int 0 $ do+ sem <- Sem.new - describe "when the semaphore is not set" $ it "returns False" do- result <- runEff . runConcurrent $ do- sem <- Sem.new- Sem.peek sem- result `shouldBe` False+ thread <- Conc.fork do+ Sem.wait sem+ put 1 - it "does not change the state of the semaphore" do- (before, after) <- runEff . runConcurrent $ do- sem <- Sem.newSet- before <- Sem.peek sem- after <- Sem.peek sem- pure (before, after)- (before, after) `shouldBe` (True, True)+ a1 <- get+ liftIO $ a1 @?= 0 - describe "withSemaphore" do- it "returns the result of the enclosed computation" do- result <- runEff . runConcurrent $ do- sem <- Sem.newSet- Sem.withSemaphore sem $ pure (42 :: Int)- result `shouldBe` 42+ Sem.signal sem - it "signals the semaphore after the computation" do- result <- runEff . runConcurrent $ do- sem <- Sem.newSet- Sem.withSemaphore sem $ pure ()- Sem.peek sem- result `shouldBe` True+ Conc.await thread - it "waits for the semaphore before running" do- result <- runEff . runConcurrent . Conc.runConc $ do- sem <- Sem.new- ref <- liftIO $ IORef.newIORef False- _ <- Conc.fork $ do- liftIO $ IORef.writeIORef ref True+ a2 <- get+ liftIO $ a2 @?= 1+ ]+ , testGroup+ "signal"+ [ testCase "sets the semaphore" do+ result <- runEff . runConcurrent $ do+ sem <- Sem.new Sem.signal sem- Sem.withSemaphore sem $ liftIO $ IORef.readIORef ref- result `shouldBe` True+ Sem.peek sem+ result @?= True+ ]+ , testGroup+ "clear"+ [ testGroup+ "when the semaphore was set"+ [ testCase "returns True" do+ result <- runEff . runConcurrent $ do+ sem <- Sem.newSet+ Sem.unset sem+ result @?= True+ ]+ , testGroup+ "when the semaphore was not set"+ [ testCase "returns False" do+ result <- runEff . runConcurrent $ do+ sem <- Sem.new+ Sem.unset sem+ result @?= False+ ]+ , testCase "leaves the semaphore clear" do+ result <- runEff . runConcurrent $ do+ sem <- Sem.newSet+ _ <- Sem.unset sem+ Sem.peek sem+ result @?= False+ ]+ , testGroup+ "reset"+ [ testGroup+ "when the semaphore was not set"+ [ testCase "returns True" do+ result <- runEff . runConcurrent $ do+ sem <- Sem.new+ Sem.set sem+ result @?= True+ ]+ , testGroup+ "when the semaphore was already set"+ [ testCase "returns False" do+ result <- runEff . runConcurrent $ do+ sem <- Sem.newSet+ Sem.set sem+ result @?= False+ ]+ , testCase "leaves the semaphore set" do+ result <- runEff . runConcurrent $ do+ sem <- Sem.new+ _ <- Sem.set sem+ Sem.peek sem+ result @?= True+ ]+ , testGroup+ "peek"+ [ testGroup+ "when the semaphore is set"+ [ testCase "returns True" do+ result <- runEff . runConcurrent $ do+ sem <- Sem.newSet+ Sem.peek sem+ result @?= True+ ]+ , testGroup+ "when the semaphore is not set"+ [ testCase "returns False" do+ result <- runEff . runConcurrent $ do+ sem <- Sem.new+ Sem.peek sem+ result @?= False+ ]+ , testCase "does not change the state of the semaphore" do+ (before, after) <- runEff . runConcurrent $ do+ sem <- Sem.newSet+ before <- Sem.peek sem+ after <- Sem.peek sem+ pure (before, after)+ (before, after) @?= (True, True)+ ]+ , testGroup+ "withSemaphore"+ [ testCase "returns the result of the enclosed computation" do+ result <- runEff . runConcurrent $ do+ sem <- Sem.newSet+ Sem.withSemaphore sem $ pure (42 :: Int)+ result @?= 42+ , testCase "signals the semaphore after the computation" do+ result <- runEff . runConcurrent $ do+ sem <- Sem.newSet+ Sem.withSemaphore sem $ pure ()+ Sem.peek sem+ result @?= True+ , testCase "waits for the semaphore before running" do+ result <- runEff . runConcurrent . Conc.runIO $ do+ sem <- Sem.new+ ref <- liftIO $ IORef.newIORef False+ _ <- Conc.fork $ do+ liftIO $ IORef.writeIORef ref True+ Sem.signal sem+ Sem.withSemaphore sem $ liftIO $ IORef.readIORef ref+ result @?= True+ ]+ ]
− test/Unit/Atelier/Types/WithDefaultsSpec.hs
@@ -1,63 +0,0 @@-module Unit.Atelier.Types.WithDefaultsSpec (spec_WithDefaults) where--import Data.Aeson (FromJSON, ToJSON, eitherDecode)-import Data.Default (Default (..))-import Test.Hspec--import Data.ByteString.Lazy qualified as LBS--import Atelier.Types.QuietSnake (QuietSnake (..))-import Atelier.Types.WithDefaults (WithDefaults (..))----- | A minimal fixture type with non-Maybe list fields to exercise WithDefaults.-data Fixture = Fixture- { requiredField :: Text- , items :: [Text]- , count :: Int- }- deriving stock (Eq, Generic, Show)- deriving (FromJSON, ToJSON) via QuietSnake Fixture---instance Default Fixture where- def =- Fixture- { requiredField = "default-value"- , items = ["default-item"]- , count = 0- }---decodeWithDefaults :: LBS.ByteString -> Either String Fixture-decodeWithDefaults bs = getQuietSnake . getWithDefaults <$> eitherDecode @(WithDefaults (QuietSnake Fixture)) bs---spec_WithDefaults :: Spec-spec_WithDefaults = do- describe "WithDefaults" do- it "falls back to Default values for missing non-Maybe fields" do- let result = decodeWithDefaults "{}"- result `shouldBe` Right def-- it "uses provided values when all fields are present" do- let result =- decodeWithDefaults- "{\"required_field\": \"hello\", \"items\": [\"a\", \"b\"], \"count\": 42}"- result- `shouldBe` Right- Fixture- { requiredField = "hello"- , items = ["a", "b"]- , count = 42- }-- it "partial object: provided fields override defaults, missing fall back" do- let result = decodeWithDefaults "{\"count\": 7}"- result- `shouldBe` Right- def {count = 7}-- it "explicitly provided empty list overrides the default list" do- let result = decodeWithDefaults "{\"items\": []}"- result `shouldBe` Right def {items = []}