From 2c1a7421f91c7cdbf0c49a2b0dcbdbeadf51120e Mon Sep 17 00:00:00 2001 From: Tommy Bidne Date: Sun, 3 Nov 2024 23:04:50 +1300 Subject: [PATCH] effectful stuff --- .github/workflows/ci.yaml | 1 + app/Main.hs | 21 +- benchmarks/Bench/Prelude.hs | 68 +++-- benchmarks/Main.hs | 35 ++- cabal.ghc982.project.freeze | 33 ++- cabal.project | 26 +- flake.lock | 81 +++--- flake.nix | 58 ++-- shrun.cabal | 80 +++--- src/Shrun.hs | 270 ++++++++---------- src/Shrun/Configuration.hs | 8 +- src/Shrun/Configuration/Args/Parsing.hs | 2 +- .../Configuration/Data/CommandLogging.hs | 7 +- .../Data/CommandLogging/PollInterval.hs | 1 - .../Data/CommandLogging/ReadSize.hs | 1 - .../Data/CommandLogging/ReadStrategy.hs | 1 - .../Configuration/Data/ConsoleLogging.hs | 5 +- .../Data/ConsoleLogging/TimerFormat.hs | 1 - src/Shrun/Configuration/Data/Core.hs | 32 +-- src/Shrun/Configuration/Data/Core/Timeout.hs | 2 - src/Shrun/Configuration/Data/FileLogging.hs | 75 +++-- .../Data/FileLogging/FileMode.hs | 1 - .../Data/FileLogging/FilePathDefault.hs | 1 - .../Data/FileLogging/FileSizeMode.hs | 1 - src/Shrun/Configuration/Data/Notify.hs | 16 +- src/Shrun/Configuration/Data/Notify/Action.hs | 1 - src/Shrun/Configuration/Data/Notify/System.hs | 1 - .../Configuration/Data/Notify/Timeout.hs | 1 - src/Shrun/Configuration/Data/Truncation.hs | 10 +- src/Shrun/Configuration/Env.hs | 118 ++++---- src/Shrun/Configuration/Env/Types.hs | 25 +- src/Shrun/Data/Command.hs | 4 +- src/Shrun/IO.hs | 177 ++++++------ src/Shrun/IO/Handle.hs | 99 +++---- src/Shrun/Logging.hs | 46 +-- src/Shrun/Logging/Formatting.hs | 7 +- src/Shrun/Logging/MonadRegionLogger.hs | 69 ----- src/Shrun/Logging/RegionLogger.hs | 95 ++++++ src/Shrun/Notify.hs | 68 +++-- src/Shrun/Notify/AppleScript.hs | 11 +- src/Shrun/Notify/DBus.hs | 62 ++-- .../Notify/{MonadNotify.hs => Effect.hs} | 21 +- src/Shrun/Notify/NotifySend.hs | 13 +- src/Shrun/Prelude.hs | 136 ++++++--- src/Shrun/ShellT.hs | 76 ----- src/Shrun/Utils.hs | 11 +- stack.yaml | 28 +- stack.yaml.lock | 216 +++++++------- .../Functional/Examples/FileLogging.hs | 5 +- test/functional/Functional/Examples/Notify.hs | 2 +- test/functional/Functional/Notify.hs | 2 +- test/functional/Functional/Prelude.hs | 159 ++++++++--- test/functional/Main.hs | 19 +- test/integration/Integration/Defaults.hs | 37 +-- test/integration/Integration/Examples.hs | 8 +- test/integration/Integration/Failures.hs | 47 +-- test/integration/Integration/Miscellaneous.hs | 89 +++--- test/integration/Integration/Prelude.hs | 25 ++ test/integration/Integration/Utils.hs | 262 +++++++++-------- test/integration/Main.hs | 30 +- test/notify/Main.hs | 134 ++++++--- test/unit/Unit/Generators.hs | 2 +- .../Unit/Shrun/Configuration/Args/Parsing.hs | 6 +- test/unit/Unit/Shrun/Logging/Formatting.hs | 32 +-- 64 files changed, 1609 insertions(+), 1372 deletions(-) delete mode 100644 src/Shrun/Logging/MonadRegionLogger.hs create mode 100644 src/Shrun/Logging/RegionLogger.hs rename src/Shrun/Notify/{MonadNotify.hs => Effect.hs} (89%) delete mode 100644 src/Shrun/ShellT.hs diff --git a/.github/workflows/ci.yaml b/.github/workflows/ci.yaml index f3b623a2..acf0ede6 100644 --- a/.github/workflows/ci.yaml +++ b/.github/workflows/ci.yaml @@ -4,6 +4,7 @@ on: branches: - main - release + - effectful pull_request: branches: - main diff --git a/app/Main.hs b/app/Main.hs index ed25d2d5..450dc9ef 100644 --- a/app/Main.hs +++ b/app/Main.hs @@ -1,6 +1,8 @@ module Main (main) where import Shrun.Configuration.Env (makeEnvAndShrun) +import Shrun.Logging.RegionLogger (runRegionLogger) +import Shrun.Notify.DBus (runDBus) import Shrun.Prelude hiding (IO) import Prelude (IO) @@ -18,7 +20,7 @@ main = do -- is just unhelpful noise. setUncaughtExceptionHandlerDisplay - makeEnvAndShrun @IO @ConsoleRegion `catch` doNothingOnSuccess + runShrun (makeEnvAndShrun @ConsoleRegion) `catch` doNothingOnSuccess where -- We need to catch ExitCode so that optparse applicative's --help -- does not set the error code to failure...but then we need to rethrow @@ -26,3 +28,20 @@ main = do doNothingOnSuccess :: ExitCode -> IO () doNothingOnSuccess ExitSuccess = pure () doNothingOnSuccess ex@(ExitFailure _) = throwM ex + + runShrun = + runEff + . runConcurrent + . runTypedProcess + . runIORef + . runOptparse + . runTime + . runFileReader + . runFileWriter + . runHandleReader + . runHandleWriter + . runPathReader + . runPathWriter + . runTerminal + . runRegionLogger + . runDBus diff --git a/benchmarks/Bench/Prelude.hs b/benchmarks/Bench/Prelude.hs index fa76f8c1..8d2ab092 100644 --- a/benchmarks/Bench/Prelude.hs +++ b/benchmarks/Bench/Prelude.hs @@ -18,18 +18,17 @@ import Shrun.Configuration.Env.Types HasNotifyConfig, HasTimeout, ) -import Shrun.Logging.MonadRegionLogger - ( MonadRegionLogger - ( Region, - displayRegions, - logGlobal, - logRegion, - withRegion +import Shrun.Logging.RegionLogger + ( RegionLogger + ( DisplayRegions, + LogGlobal, + LogRegion, + WithRegion ), ) -import Shrun.Notify.MonadNotify (MonadNotify (notify)) +import Shrun.Notify.DBus (runDBus) +import Shrun.Notify.Effect (Notify (Notify)) import Shrun.Prelude -import Shrun.ShellT (ShellT) import System.Environment qualified as SysEnv newtype BenchEnv = MkBenchEnv @@ -49,22 +48,45 @@ newtype BenchEnv = MkBenchEnv instance HasConsoleLogging BenchEnv () where getConsoleLogging = getConsoleLogging . (.unCoreEnv) -instance MonadRegionLogger (ShellT BenchEnv IO) where - type Region (ShellT BenchEnv IO) = () +runRegionLogger :: + ( r ~ (), + IOE :> es + ) => + Eff (RegionLogger r : es) a -> + Eff es a +runRegionLogger = interpret $ \env -> \case + LogGlobal _ -> pure () + LogRegion {} -> pure () + WithRegion _ regionToShell -> localSeqUnliftIO env $ \unlift -> + unlift (regionToShell ()) + DisplayRegions m -> localSeqUnliftIO env $ \unlift -> unlift m - logGlobal _ = pure () - - logRegion _ _ = logGlobal - - withRegion _layout regionToShell = regionToShell () - - displayRegions = id - -instance MonadNotify (ShellT BenchEnv IO) where - notify _ = pure Nothing +runNotify :: Eff (Notify : es) a -> Eff es a +runNotify = interpret_ $ \case + Notify _ -> pure Nothing runBench :: List String -> IO () runBench argList = do - SysEnv.withArgs argList $ Env.withEnv $ \env -> do + SysEnv.withArgs argList $ runShrun $ Env.withEnv $ \env -> do let benchEnv = MkBenchEnv env - SR.runShellT SR.shrun benchEnv + runReader benchEnv + $ runRegionLogger + $ runNotify + $ SR.shrun @BenchEnv @() + where + runShrun = + runEff + . runConcurrent + . runTypedProcess + . runIORef + . runOptparse + . runTime + . runFileReader + . runFileWriter + . runHandleReader + . runHandleWriter + . runPathReader + . runPathWriter + . runTerminal + . runRegionLogger + . runDBus diff --git a/benchmarks/Main.hs b/benchmarks/Main.hs index e892f1c6..fc5b92e5 100644 --- a/benchmarks/Main.hs +++ b/benchmarks/Main.hs @@ -4,8 +4,9 @@ module Main (main) where import Bench.Prelude import Control.DeepSeq (force) -import Effects.FileSystem.PathReader qualified as RDir -import Effects.FileSystem.PathWriter qualified as WDir +import Effectful.FileSystem.PathReader.Static qualified as PR +import Effectful.FileSystem.PathWriter.Static qualified as PW +import Effectful.Terminal.Static qualified as Term import FileSystem.OsPath (unsafeDecode) import Shrun.Prelude hiding (IO) import System.Environment.Guard (ExpectEnv (ExpectEnvSet), guardOrElse') @@ -64,19 +65,39 @@ bashLoop :: String -> String bashLoop bound = "for i in {1.." ++ bound ++ "}; do echo ${i}; done" setup :: IO OsPath -setup = do +setup = runBenchEff $ do testDir <- (\tmp -> tmp [osp|shrun|] [osp|bench|]) - <$> RDir.getTemporaryDirectory - WDir.createDirectoryIfMissing True testDir + <$> PR.getTemporaryDirectory + PW.createDirectoryIfMissing True testDir pure testDir teardown :: OsPath -> IO () teardown testDir = guardOrElse' "NO_CLEANUP" ExpectEnvSet doNothing cleanup where - cleanup = WDir.removePathForcibly testDir + cleanup = runBenchEff $ PW.removePathForcibly testDir doNothing = - putStrLn + runBenchEff + $ Term.putStrLn $ "*** Not cleaning up tmp dir: '" <> decodeLenient testDir <> "'" + +runBenchEff :: + (HasCallStack, MonadIO m) => + Eff + [ FileWriter, + Term.Terminal, + PW.PathWriter, + PR.PathReader, + IOE + ] + a -> + m a +runBenchEff = + liftIO + . runEff + . PR.runPathReader + . PW.runPathWriter + . Term.runTerminal + . runFileWriter diff --git a/cabal.ghc982.project.freeze b/cabal.ghc982.project.freeze index d688a41f..2b6d56bb 100644 --- a/cabal.ghc982.project.freeze +++ b/cabal.ghc982.project.freeze @@ -28,6 +28,7 @@ constraints: any.OneTuple ==0.4.2, any.cereal ==0.5.8.3, any.colour ==2.3.6, any.comonad ==5.0.8, + any.concurrent-effectful ==0.1, any.concurrent-output ==1.10.21, any.conduit ==1.3.5, any.conduit-extra ==1.3.6, @@ -45,18 +46,10 @@ constraints: any.OneTuple ==0.4.2, any.directory ==1.3.8.1, any.distributive ==0.6.2.1, any.dlist ==1.0, - any.effects-async ==0.1, - any.effects-env ==0.1, - any.effects-fs ==0.1, - any.effects-ioref ==0.1, - any.effects-optparse ==0.1, - any.effects-stm ==0.1, - any.effects-terminal ==0.1, - any.effects-thread ==0.1, - any.effects-time ==0.1, - any.effects-typed-process ==0.1, - any.effects-unix-compat ==0.1, + any.effectful ==2.5.0.0, + any.effectful-core ==2.5.0.0, any.env-guard ==0.2, + any.environment-effectful ==0.1, any.erf ==2.0.0.0, any.exception-utils ==0.1, any.exceptions ==0.10.7, @@ -64,6 +57,7 @@ constraints: any.OneTuple ==0.4.2, any.file-io ==0.1.1, any.filepath ==1.4.200.1, any.free ==5.2, + any.fs-effectful ==0.1, any.fs-utils ==0.1, any.generically ==0.1.1, any.ghc-bignum ==1.3, @@ -78,6 +72,7 @@ constraints: any.OneTuple ==0.4.2, any.integer-conversion ==0.1.0.1, any.integer-logarithms ==1.0.3.1, any.invariant ==0.6.3, + any.ioref-effectful ==0.1, any.kan-extensions ==5.2.6, any.lens ==5.2.3, any.lifted-async ==0.10.2.5, @@ -94,6 +89,7 @@ constraints: any.OneTuple ==0.4.2, any.old-locale ==1.0.0.7, any.optics-core ==0.4.1.1, any.optparse-applicative ==0.18.1.0, + any.optparse-effectful ==0.1, any.os-string ==2.0.2.2, any.parallel ==3.2.2.0, any.parsec ==3.1.17.0, @@ -122,18 +118,22 @@ constraints: any.OneTuple ==0.4.2, any.split ==0.2.5, any.splitmix ==0.1.0.5, any.stm ==2.5.2.1, + any.stm-effectful ==0.1, any.streaming-commons ==0.2.2.6, any.strict ==0.5, + any.strict-mutable-base ==1.1.0.0, any.tagged ==0.8.8, any.tasty ==1.4.3, - any.tasty-bench ==0.3.5, - tasty-bench -debug +tasty, + any.tasty-bench ==0.4, + tasty-bench +tasty, any.tasty-hedgehog ==1.4.0.2, any.tasty-hunit ==0.10.1, any.template-haskell ==2.21.0.0, + any.terminal-effectful ==0.1, any.terminal-size ==0.3.4, any.text ==2.1.1, any.text-display ==0.0.5.2, + text-display -book, any.text-iso8601 ==0.1, any.text-short ==0.1.6, any.th-abstraction ==0.7.0.0, @@ -142,13 +142,16 @@ constraints: any.OneTuple ==0.4.2, any.these ==1.2, any.time ==1.12.2, any.time-compat ==1.9.6.1, + any.time-effectful ==0.1, any.toml-reader ==0.2.1.0, any.transformers ==0.6.1.0, any.transformers-base ==0.4.6, any.transformers-compat ==0.7.2, any.typed-process ==0.2.11.1, + any.typed-process-effectful ==1.0.0.3, any.unix ==2.8.4.0, - any.unix-compat ==0.7.2, + any.unix-compat ==0.7.3, + any.unix-compat-effectful ==0.1, any.unliftio ==0.2.25.0, any.unliftio-core ==0.2.1.0, any.unordered-containers ==0.2.20, @@ -162,4 +165,4 @@ constraints: any.OneTuple ==0.4.2, any.xml-conduit ==1.9.1.3, any.xml-types ==0.3.8, any.zlib ==0.6.3.0 -index-state: hackage.haskell.org 2024-07-02T09:47:50Z +index-state: hackage.haskell.org 2024-10-29T08:03:20Z diff --git a/cabal.project b/cabal.project index 6d0b5759..6bbfdb83 100644 --- a/cabal.project +++ b/cabal.project @@ -1,4 +1,4 @@ -index-state: 2024-07-02T09:47:50Z +index-state: 2024-10-29T08:03:20Z packages: . @@ -48,20 +48,18 @@ source-repository-package source-repository-package type: git - location: https://github.com/tbidne/monad-effects.git - tag: 8021f9a0855e644d91b73e6b2bcf20406ebbebb8 + location: https://github.com/tbidne/effectful-effects.git + tag: 3ba8c43901087915bc9418c8ed095a7fad4f8ac1 subdir: - lib/effects-async - lib/effects-env - lib/effects-fs - lib/effects-ioref - lib/effects-optparse - lib/effects-stm - lib/effects-time - lib/effects-terminal - lib/effects-thread - lib/effects-typed-process - lib/effects-unix-compat + lib/concurrent-effectful + lib/environment-effectful + lib/fs-effectful + lib/ioref-effectful + lib/optparse-effectful + lib/stm-effectful + lib/time-effectful + lib/terminal-effectful + lib/unix-compat-effectful source-repository-package type: git diff --git a/flake.lock b/flake.lock index c5612840..2cb4b99d 100644 --- a/flake.lock +++ b/flake.lock @@ -52,6 +52,44 @@ "type": "github" } }, + "effectful-effects": { + "inputs": { + "algebra-simple": [ + "algebra-simple" + ], + "bounds": [ + "bounds" + ], + "exception-utils": [ + "exception-utils" + ], + "flake-parts": [ + "flake-parts" + ], + "fs-utils": [ + "fs-utils" + ], + "nix-hs-utils": [ + "nix-hs-utils" + ], + "nixpkgs": [ + "nixpkgs" + ] + }, + "locked": { + "lastModified": 1730415413, + "narHash": "sha256-WPvDJfTa71Tmupe8OWyuNRmsNBwjcD6io/IAtdb5nAw=", + "owner": "tbidne", + "repo": "effectful-effects", + "rev": "3ba8c43901087915bc9418c8ed095a7fad4f8ac1", + "type": "github" + }, + "original": { + "owner": "tbidne", + "repo": "effectful-effects", + "type": "github" + } + }, "exception-utils": { "inputs": { "flake-parts": [ @@ -122,47 +160,6 @@ "type": "github" } }, - "monad-effects": { - "inputs": { - "algebra-simple": [ - "algebra-simple" - ], - "bounds": [ - "bounds" - ], - "exception-utils": [ - "exception-utils" - ], - "flake-parts": [ - "flake-parts" - ], - "fs-utils": [ - "fs-utils" - ], - "nix-hs-utils": [ - "nix-hs-utils" - ], - "nixpkgs": [ - "nixpkgs" - ], - "smart-math": [ - "smart-math" - ] - }, - "locked": { - "lastModified": 1730241078, - "narHash": "sha256-zMWB/KJ7stYZ+fMAbEQkWnmW0ASzdBG44hjerYXOeA8=", - "owner": "tbidne", - "repo": "monad-effects", - "rev": "8021f9a0855e644d91b73e6b2bcf20406ebbebb8", - "type": "github" - }, - "original": { - "owner": "tbidne", - "repo": "monad-effects", - "type": "github" - } - }, "nix-hs-utils": { "locked": { "lastModified": 1713310032, @@ -242,10 +239,10 @@ "inputs": { "algebra-simple": "algebra-simple", "bounds": "bounds", + "effectful-effects": "effectful-effects", "exception-utils": "exception-utils", "flake-parts": "flake-parts", "fs-utils": "fs-utils", - "monad-effects": "monad-effects", "nix-hs-utils": "nix-hs-utils", "nixpkgs": "nixpkgs", "relative-time": "relative-time", diff --git a/flake.nix b/flake.nix index 305ee8b9..fcaec539 100644 --- a/flake.nix +++ b/flake.nix @@ -31,8 +31,8 @@ inputs.nix-hs-utils.follows = "nix-hs-utils"; inputs.nixpkgs.follows = "nixpkgs"; }; - monad-effects = { - url = "github:tbidne/monad-effects"; + effectful-effects = { + url = "github:tbidne/effectful-effects"; inputs.flake-parts.follows = "flake-parts"; inputs.nix-hs-utils.follows = "nix-hs-utils"; inputs.nixpkgs.follows = "nixpkgs"; @@ -41,7 +41,6 @@ inputs.bounds.follows = "bounds"; inputs.exception-utils.follows = "exception-utils"; inputs.fs-utils.follows = "fs-utils"; - inputs.smart-math.follows = "smart-math"; }; relative-time = { url = "github:tbidne/relative-time"; @@ -87,7 +86,36 @@ compiler = pkgs.haskell.packages."${ghc-version}".override { overrides = final: prev: - { } + { + effectful-core = ( + final.callHackageDirect { + pkg = "effectful-core"; + ver = "2.5.0.0"; + sha256 = "sha256-UCbMP8BfNfdIRTLzB4nBr17jxRp5Qmw3sTuORO06Npg="; + } { } + ); + effectful = ( + final.callHackageDirect { + pkg = "effectful"; + ver = "2.5.0.0"; + sha256 = "sha256-lmM0kdM5PS45Jol5Y2Nw30VWWfDPiPJLrwVj+GmJSOQ="; + } { } + ); + strict-mutable-base = ( + final.callHackageDirect { + pkg = "strict-mutable-base"; + ver = "1.1.0.0"; + sha256 = "sha256-cBSwoNGU/GZDW3eg7GI28t0HrrrxMW9hRapoOL2zU7Q="; + } { } + ); + typed-process-effectful = hlib.dontCheck ( + final.callHackageDirect { + pkg = "typed-process-effectful"; + ver = "1.0.0.3"; + sha256 = "sha256-q7auI60lmW2X9PHCLPPVOqIfRXET1dAr8VHhCtmecYI="; + } { } + ); + } // nix-hs-utils.mkLibs inputs final [ "algebra-simple" "bounds" @@ -97,18 +125,16 @@ "si-bytes" "smart-math" ] - // nix-hs-utils.mkRelLibs "${inputs.monad-effects}/lib" final [ - "effects-async" - "effects-env" - "effects-fs" - "effects-ioref" - "effects-optparse" - "effects-stm" - "effects-terminal" - "effects-thread" - "effects-time" - "effects-typed-process" - "effects-unix-compat" + // nix-hs-utils.mkRelLibs "${inputs.effectful-effects}/lib" final [ + "concurrent-effectful" + "environment-effectful" + "fs-effectful" + "ioref-effectful" + "optparse-effectful" + "stm-effectful" + "terminal-effectful" + "time-effectful" + "unix-compat-effectful" ]; }; hlib = pkgs.haskell.lib; diff --git a/shrun.cabal b/shrun.cabal index 70f83f17..80fe5d85 100644 --- a/shrun.cabal +++ b/shrun.cabal @@ -113,48 +113,46 @@ library Shrun.IO.Handle Shrun.Logging Shrun.Logging.Formatting - Shrun.Logging.MonadRegionLogger + Shrun.Logging.RegionLogger Shrun.Logging.Types Shrun.Logging.Types.Internal Shrun.Notify Shrun.Notify.AppleScript Shrun.Notify.DBus - Shrun.Notify.MonadNotify + Shrun.Notify.Effect Shrun.Notify.NotifySend Shrun.Prelude - Shrun.ShellT Shrun.Utils build-depends: - , base >=4.17 && <4.21 - , bytestring >=0.10.12 && <0.13 - , concurrent-output ^>=1.10.7 - , containers >=0.6.2.1 && <0.8 - , dbus >=1.2.14 && <1.4 - , effects-async ^>=0.1 - , effects-env ^>=0.1 - , effects-fs ^>=0.1 - , effects-ioref ^>=0.1 - , effects-optparse ^>=0.1 - , effects-stm ^>=0.1 - , effects-terminal ^>=0.1 - , effects-thread ^>=0.1 - , effects-time ^>=0.1 - , effects-typed-process ^>=0.1 - , exception-utils ^>=0.1 - , exceptions ^>=0.10.4 - , fdo-notify ^>=0.3.1 - , hashable >=1.3.0.0 && <1.6 - , mtl >=2.2.1 && <2.4 - , nonempty-containers >=0.3.4.2 && <0.4 - , optics-core ^>=0.4 - , optparse-applicative >=0.15 && <0.19 - , pretty-terminal ^>=0.1 - , relative-time ^>=0.1 - , si-bytes ^>=0.1 - , text >=1.2.3.2 && <2.2 - , toml-reader >=0.2.0.0 && <0.3.0.0 - , unordered-containers ^>=0.2.9.0 + , base >=4.17 && <4.21 + , bytestring >=0.10.12 && <0.13 + , concurrent-effectful ^>=0.1 + , concurrent-output ^>=1.10.7 + , containers >=0.6.2.1 && <0.8 + , dbus >=1.2.14 && <1.4 + , effectful >=2.5.0.0 && <2.6 + , exception-utils ^>=0.1 + , exceptions ^>=0.10.4 + , fdo-notify ^>=0.3.1 + , fs-effectful ^>=0.1 + , hashable >=1.3.0.0 && <1.6 + , ioref-effectful ^>=0.1 + , mtl >=2.2.1 && <2.4 + , nonempty-containers >=0.3.4.2 && <0.4 + , optics-core ^>=0.4 + , optparse-applicative >=0.15 && <0.19 + , optparse-effectful ^>=0.1 + , pretty-terminal ^>=0.1 + , relative-time ^>=0.1 + , si-bytes ^>=0.1 + , stm-effectful ^>=0.1 + , terminal-effectful ^>=0.1 + , text >=1.2.3.2 && <2.2 + , time-effectful ^>=0.1 + , toml-reader >=0.2.0.0 && <0.3.0.0 + , typed-process-effectful ^>=1.0.0.3 + , unordered-containers ^>=0.2.9.0 -- For tuple syntax if impl(ghc >=9.10.1) @@ -209,7 +207,6 @@ test-suite unit build-depends: , base , containers - , effects-time , hedgehog >=1.0.2 && <1.6 , optparse-applicative , shrun @@ -219,6 +216,7 @@ test-suite unit , tasty-hunit >=0.9 && <0.11 , text , time >=1.9.3 && <1.15 + , time-effectful , unordered-containers hs-source-dirs: test/unit @@ -239,15 +237,15 @@ test-suite integration build-depends: , base , dbus - , effects-fs - , effects-terminal , env-guard + , fs-effectful , hedgehog , nonempty-containers , shrun , tasty , tasty-hedgehog , tasty-hunit + , terminal-effectful , text hs-source-dirs: test/integration @@ -273,15 +271,16 @@ test-suite functional build-depends: , base - , effects-fs , env-guard , fdo-notify + , fs-effectful , optparse-applicative , shrun , shrun-verifier , tagged ^>=0.8.6 , tasty , tasty-hunit + , terminal-effectful , text hs-source-dirs: test/functional @@ -308,10 +307,11 @@ benchmark benchmarks other-modules: Bench.Prelude build-depends: , base - , deepseq >=1.4.4.0 && <1.6 - , effects-fs - , env-guard ^>=0.2 + , deepseq >=1.4.4.0 && <1.6 + , env-guard ^>=0.2 + , fs-effectful , shrun - , tasty-bench >=0.3 && <0.5 + , tasty-bench >=0.3 && <0.5 + , terminal-effectful hs-source-dirs: benchmarks diff --git a/src/Shrun.hs b/src/Shrun.hs index b37d650e..a73fbdb1 100644 --- a/src/Shrun.hs +++ b/src/Shrun.hs @@ -1,17 +1,17 @@ +{-# LANGUAGE AllowAmbiguousTypes #-} + -- | This module is the entry point to the @Shrun@ library used by -- the @Shrun@ executable. module Shrun - ( ShellT, - runShellT, - shrun, + ( shrun, ) where import DBus.Notify (UrgencyLevel (Critical, Normal)) import Data.HashSet qualified as Set -import Effects.Concurrent.Async qualified as Async -import Effects.Concurrent.Thread as X (microsleep, sleep) -import Effects.Time (TimeSpec, withTiming) +import Effectful.Concurrent.Async qualified as Async +import Effectful.Concurrent.Static (microsleep, sleep) +import Effectful.Time.Dynamic (TimeSpec, withTiming) import Shrun.Configuration.Data.ConsoleLogging.TimerFormat qualified as TimerFormat import Shrun.Configuration.Data.Core.Timeout (Timeout (MkTimeout)) import Shrun.Configuration.Data.FileLogging @@ -46,14 +46,12 @@ import Shrun.IO ) import Shrun.Logging qualified as Logging import Shrun.Logging.Formatting qualified as LogFmt -import Shrun.Logging.MonadRegionLogger - ( MonadRegionLogger - ( Region, - displayRegions, - logGlobal, - logRegion, - withRegion - ), +import Shrun.Logging.RegionLogger + ( RegionLogger, + displayRegions, + logGlobal, + logRegion, + withRegion, ) import Shrun.Logging.Types ( FileLog, @@ -70,42 +68,38 @@ import Shrun.Logging.Types LogRegion (LogNoRegion, LogRegion), ) import Shrun.Notify qualified as Notify -import Shrun.Notify.MonadNotify (MonadNotify) +import Shrun.Notify.Effect (Notify) import Shrun.Prelude -import Shrun.ShellT (ShellT, runShellT) import Shrun.Utils qualified as Utils -- | Entry point shrun :: - forall m env. - ( HasAnyError env, + forall env r es. + ( Concurrent :> es, + HasAnyError env, HasCallStack, HasCommands env, HasInit env, HasCommandLogging env, HasCommonLogging env, - HasConsoleLogging env (Region m), + HasConsoleLogging env r, HasFileLogging env, HasNotifyConfig env, HasTimeout env, - MonadAsync m, - MonadHandleReader m, - MonadHandleWriter m, - MonadIORef m, - MonadNotify m, - MonadTypedProcess m, - MonadMask m, - MonadReader env m, - MonadRegionLogger m, - MonadSTM m, - MonadThread m, - MonadTime m + HandleReader :> es, + HandleWriter :> es, + IORefE :> es, + Notify :> es, + TypedProcess :> es, + Reader env :> es, + RegionLogger r :> es, + Time :> es ) => -- | . - m () -shrun = displayRegions $ do - mFileLogging <- asks getFileLogging - (_, consoleQueue) <- asks getConsoleLogging + Eff es () +shrun = displayRegions @r $ do + mFileLogging <- asks @env getFileLogging + (_, consoleQueue) <- asks @env (getConsoleLogging @env @r) -- always start console logger Async.withAsync (pollQueueToConsole consoleQueue) $ \consoleLogger -> do @@ -120,10 +114,10 @@ shrun = displayRegions $ do flushTBQueueA consoleQueue >>= traverse_ printConsoleLog -- if any processes have failed, exit with an error - anyError <- readTVarA =<< asks getAnyError + anyError <- readTVarA =<< asks @env getAnyError when anyError exitFailure where - runWithFileLogging :: (HasCallStack) => FileLoggingEnv -> m () + runWithFileLogging :: (HasCallStack) => FileLoggingEnv -> Eff es () runWithFileLogging fileLogging = Async.withAsync (pollQueueToFile fileLogging) $ \fileLoggerThread -> do runCommands @@ -135,47 +129,42 @@ shrun = displayRegions $ do hFlush h where MkFileLogOpened h fileQueue = fileLogging ^. #file - {-# INLINEABLE runWithFileLogging #-} - runCommands :: (HasCallStack) => m () + runCommands :: (HasCallStack) => Eff es () runCommands = do - cmds <- asks getCommands - let actions = Async.mapConcurrently_ runCommand cmds - actionsWithTimer = Async.race_ actions counter + cmds <- asks @env getCommands + let actions = Async.mapConcurrently_ (runCommand @env @r) cmds + actionsWithTimer = Async.race_ actions (counter @env @r) (totalTime, result) <- withTiming $ trySync actionsWithTimer - printFinalResult totalTime result - {-# INLINEABLE runCommands #-} -{-# INLINEABLE shrun #-} + printFinalResult @env @r totalTime result runCommand :: - forall m env. + forall env r es. ( HasAnyError env, HasCallStack, HasCommands env, HasInit env, HasCommandLogging env, HasCommonLogging env, - HasConsoleLogging env (Region m), + HasConsoleLogging env r, HasFileLogging env, HasNotifyConfig env, - MonadHandleReader m, - MonadIORef m, - MonadMask m, - MonadNotify m, - MonadTypedProcess m, - MonadReader env m, - MonadRegionLogger m, - MonadSTM m, - MonadThread m, - MonadTime m + HandleReader :> es, + IORefE :> es, + Notify :> es, + TypedProcess :> es, + Reader env :> es, + RegionLogger r :> es, + Concurrent :> es, + Time :> es ) => CommandP1 -> - m () + Eff es () runCommand cmd = do - cmdResult <- tryCommandLogging cmd - commonLogging <- asks getCommonLogging - (consoleLogging, _) <- asks (getConsoleLogging @env @(Region m)) + cmdResult <- tryCommandLogging @env @r cmd + commonLogging <- asks @env getCommonLogging + (consoleLogging, _) <- asks @env (getConsoleLogging @env @r) let timerFormat = consoleLogging ^. #timerFormat (urgency, msg', lvl, timeElapsed) = case cmdResult of @@ -187,8 +176,8 @@ runCommand cmd = do CommandSuccess t -> (Normal, "", LevelSuccess, t) timeMsg = TimerFormat.formatRelativeTime timerFormat timeElapsed <> msg' - withRegion Linear $ \r -> - Logging.putRegionLog r + withRegion @r Linear $ \r -> + Logging.putRegionLog @env @r r $ MkLog { cmd = Just cmd, msg = timeMsg, @@ -201,32 +190,31 @@ runCommand cmd = do formattedCmd = LogFmt.formatCommand keyHide commandNameTrunc cmd -- Sent off notif if NotifyAll or NotifyCommand is set - cfg <- asks getNotifyConfig + cfg <- asks @env getNotifyConfig case cfg ^? (_Just % #action) of - Just NotifyAll -> Notify.sendNotif (formattedCmd <> " Finished") timeMsg urgency - Just NotifyCommand -> Notify.sendNotif (formattedCmd <> " Finished") timeMsg urgency + Just NotifyAll -> Notify.sendNotif @env @r (formattedCmd <> " Finished") timeMsg urgency + Just NotifyCommand -> Notify.sendNotif @env @r (formattedCmd <> " Finished") timeMsg urgency _ -> pure () -{-# INLINEABLE runCommand #-} printFinalResult :: - forall m env e b. + forall env r es e b. ( Exception e, HasAnyError env, HasCallStack, HasCommonLogging env, - HasConsoleLogging env (Region m), + HasConsoleLogging env r, HasFileLogging env, HasNotifyConfig env, - MonadNotify m, - MonadReader env m, - MonadRegionLogger m, - MonadSTM m, - MonadTime m + Notify :> es, + Reader env :> es, + RegionLogger r :> es, + Concurrent :> es, + Time :> es ) => TimeSpec -> Either e b -> - m () -printFinalResult totalTime result = withRegion Linear $ \r -> do + Eff es () +printFinalResult totalTime result = withRegion @r Linear $ \r -> do Utils.whenLeft result $ \ex -> do let errMsg = mconcat @@ -241,12 +229,12 @@ printFinalResult totalTime result = withRegion Linear $ \r -> do lvl = LevelFatal, mode = LogModeFinish } - Logging.putRegionLog r fatalLog + Logging.putRegionLog @env @r r fatalLog -- update anyError - setAnyErrorTrue + setAnyErrorTrue @env - timerFormat <- asks (view (_1 % #timerFormat) . getConsoleLogging @_ @(Region m)) + timerFormat <- asks @env (view (_1 % #timerFormat) . getConsoleLogging @_ @r) let totalTimeTxt = TimerFormat.formatRelativeTime timerFormat @@ -260,62 +248,60 @@ printFinalResult totalTime result = withRegion Linear $ \r -> do } -- Send off a 'finished' notification - anyError <- readTVarA =<< asks getAnyError + anyError <- readTVarA =<< asks @env getAnyError let urgency = if anyError then Critical else Normal -- Sent off notif if NotifyAll or NotifyFinal is set - cfg <- asks getNotifyConfig + cfg <- asks @env getNotifyConfig case cfg ^? (_Just % #action) of - Just NotifyAll -> Notify.sendNotif "Shrun Finished" totalTimeTxt urgency - Just NotifyFinal -> Notify.sendNotif "Shrun Finished" totalTimeTxt urgency + Just NotifyAll -> Notify.sendNotif @env @r "Shrun Finished" totalTimeTxt urgency + Just NotifyFinal -> Notify.sendNotif @env @r "Shrun Finished" totalTimeTxt urgency _ -> pure () - Logging.putRegionLog r finalLog -{-# INLINEABLE printFinalResult #-} + Logging.putRegionLog @env @r r finalLog counter :: + forall env r es. ( HasAnyError env, HasCallStack, HasCommands env, HasCommonLogging env, - HasConsoleLogging env (Region m), + HasConsoleLogging env r, HasFileLogging env, HasTimeout env, - MonadIORef m, - MonadReader env m, - MonadRegionLogger m, - MonadSTM m, - MonadThread m, - MonadTime m + IORefE :> es, + Reader env :> es, + RegionLogger r :> es, + Concurrent :> es, + Time :> es ) => - m () + Eff es () counter = do -- HACK: This brief delay is so that our timer starts "last" i.e. after each -- individual command. This way the running timer console region is below all -- the commands' in the console. microsleep 100_000 - withRegion Linear $ \r -> do - timeout <- asks getTimeout + withRegion @r Linear $ \r -> do + timeout <- asks @env getTimeout timer <- newIORef 0 - Utils.whileM_ (keepRunning r timer timeout) $ do + Utils.whileM_ (keepRunning @env @r r timer timeout) $ do sleep 1 elapsed <- atomicModifyIORef' timer $ \t -> (t + 1, t + 1) - logCounter r elapsed -{-# INLINEABLE counter #-} + logCounter @env @r r elapsed logCounter :: - forall m env. + forall env r es. ( HasCallStack, HasCommonLogging env, - HasConsoleLogging env (Region m), - MonadReader env m, - MonadSTM m + HasConsoleLogging env r, + Reader env :> es, + Concurrent :> es ) => - Region m -> + r -> Natural -> - m () + Eff es () logCounter region elapsed = do - timerFormat <- asks (view (_1 % #timerFormat) . getConsoleLogging @_ @(Region m)) + timerFormat <- asks @env (view (_1 % #timerFormat) . getConsoleLogging @_ @r) let msg = TimerFormat.formatSeconds timerFormat elapsed lg = @@ -325,37 +311,36 @@ logCounter region elapsed = do lvl = LevelTimer, mode = LogModeSet } - Logging.regionLogToConsoleQueue region lg -{-# INLINEABLE logCounter #-} + Logging.regionLogToConsoleQueue @env region lg keepRunning :: - forall m env. + forall env r es. ( HasAnyError env, HasCallStack, HasCommands env, HasCommonLogging env, - HasConsoleLogging env (Region m), + HasConsoleLogging env r, HasFileLogging env, - MonadIORef m, - MonadReader env m, - MonadSTM m, - MonadTime m + IORefE :> es, + Reader env :> es, + Concurrent :> es, + Time :> es ) => - Region m -> + r -> IORef Natural -> Maybe Timeout -> - m Bool + Eff es Bool keepRunning region timer mto = do elapsed <- readIORef timer if timedOut elapsed mto then do - keyHide <- asks (view #keyHide . getCommonLogging) - allCmds <- asks getCommands - completedCommandsTVar <- asks getCompletedCommands + keyHide <- asks @env (view #keyHide . getCommonLogging) + allCmds <- asks @env getCommands + completedCommandsTVar <- asks @env getCompletedCommands completedCommands <- readTVarA completedCommandsTVar -- update anyError - setAnyErrorTrue + setAnyErrorTrue @env let completedCommandsSet = Set.fromList $ toList completedCommands allCmdsSet = Set.fromList $ toList allCmds @@ -366,7 +351,7 @@ keepRunning region timer mto = do ShrunText.intercalate ", " $ foldl' toTxtList [] incompleteCmds - Logging.putRegionLog region + Logging.putRegionLog @env @r region $ MkLog { cmd = Nothing, msg = "Timed out, cancelling remaining commands: " <> unfinishedCmds, @@ -375,72 +360,65 @@ keepRunning region timer mto = do } pure False else pure True -{-# INLINEABLE keepRunning #-} timedOut :: Natural -> Maybe Timeout -> Bool timedOut _ Nothing = False timedOut timer (Just (MkTimeout t)) = timer > t pollQueueToConsole :: + forall r es void. ( HasCallStack, - MonadMask m, - MonadReader env m, - MonadRegionLogger m, - MonadSTM m + RegionLogger r :> es, + Concurrent :> es ) => - TBQueue (LogRegion (Region m)) -> - m void + TBQueue (LogRegion r) -> + Eff es void pollQueueToConsole queue = do -- NOTE: Same masking behavior as pollQueueToFile. forever $ atomicReadWrite queue printConsoleLog -{-# INLINEABLE pollQueueToConsole #-} printConsoleLog :: + forall r es. ( HasCallStack, - MonadRegionLogger m + RegionLogger r :> es ) => - LogRegion (Region m) -> - m () -printConsoleLog (LogNoRegion consoleLog) = logGlobal (consoleLog ^. #unConsoleLog) + LogRegion r -> + Eff es () +printConsoleLog (LogNoRegion consoleLog) = logGlobal @r (consoleLog ^. #unConsoleLog) printConsoleLog (LogRegion m r consoleLog) = logRegion m r (consoleLog ^. #unConsoleLog) -{-# INLINEABLE printConsoleLog #-} pollQueueToFile :: + forall es void. ( HasCallStack, - MonadHandleWriter m, - MonadMask m, - MonadSTM m + HandleWriter :> es, + Concurrent :> es ) => FileLoggingEnv -> - m void + Eff es void pollQueueToFile fileLogging = do forever $ -- NOTE: Read+write needs to be atomic, otherwise we can lose logs -- (i.e. thread reads the log and is cancelled before it can write it). -- Hence the mask. - atomicReadWrite queue (logFile h) + atomicReadWrite queue (logFile @es h) where MkFileLogOpened h queue = fileLogging ^. #file -{-# INLINEABLE pollQueueToFile #-} -logFile :: (HasCallStack, MonadHandleWriter m) => Handle -> FileLog -> m () +logFile :: (HasCallStack, HandleWriter :> es) => Handle -> FileLog -> Eff es () logFile h = (\t -> hPutUtf8 h t *> hFlush h) . view #unFileLog -{-# INLINEABLE logFile #-} -- | Reads from a queue and applies the function, if we receive a value. -- Atomic in the sense that if a read is successful, then we will apply the -- given function, even if an async exception is raised. atomicReadWrite :: ( HasCallStack, - MonadMask m, - MonadSTM m + Concurrent :> es ) => -- | Queue from which to read. TBQueue a -> -- | Function to apply. - (a -> m b) -> - m () + (a -> Eff es b) -> + Eff es () atomicReadWrite queue logAction = mask $ \restore -> restore (readTBQueueA queue) >>= void . logAction -{-# INLINEABLE atomicReadWrite #-} diff --git a/src/Shrun/Configuration.hs b/src/Shrun/Configuration.hs index 33aefcdc..a2f6de62 100644 --- a/src/Shrun/Configuration.hs +++ b/src/Shrun/Configuration.hs @@ -23,7 +23,7 @@ import Shrun.Prelude -- We want this function to do as much to prepare the final config as -- possible. For instance, in addition to filling in defaults, we also process -- commands via the legend (MonadThrow) and detect the terminal width for --- command logging's lineTrunc field (MonadTerminal). +-- command logging's lineTrunc field (Terminal). -- -- This is very nearly pure, except for the aforementioned effects. -- The only remaining tasks the Env needs to take care of is IO that we @@ -31,12 +31,11 @@ import Shrun.Prelude -- queues. mergeConfig :: ( HasCallStack, - MonadTerminal m, - MonadThrow m + Terminal :> es ) => Args -> Maybe Toml -> - m MergedConfig + Eff es MergedConfig mergeConfig args mToml = do case mToml of Nothing -> do @@ -75,4 +74,3 @@ mergeConfig args mToml = do } where cmdsText = args ^. #commands -{-# INLINEABLE mergeConfig #-} diff --git a/src/Shrun/Configuration/Args/Parsing.hs b/src/Shrun/Configuration/Args/Parsing.hs index 8703c719..3e8df5be 100644 --- a/src/Shrun/Configuration/Args/Parsing.hs +++ b/src/Shrun/Configuration/Args/Parsing.hs @@ -14,7 +14,7 @@ import Data.List qualified as L import Data.String (IsString (fromString)) import Data.Text qualified as T import Data.Version (Version (versionBranch)) -import Effects.Optparse (validOsPath) +import Effectful.Optparse.Static (validOsPath) import Options.Applicative ( Parser, ParserInfo diff --git a/src/Shrun/Configuration/Data/CommandLogging.hs b/src/Shrun/Configuration/Data/CommandLogging.hs index 6b389c53..c7ed0be0 100644 --- a/src/Shrun/Configuration/Data/CommandLogging.hs +++ b/src/Shrun/Configuration/Data/CommandLogging.hs @@ -81,7 +81,6 @@ parseBufferLength getNat = do case convertIntegral n of Left err -> fail err Right x -> pure $ MkBufferLength x -{-# INLINEABLE parseBufferLength #-} newtype BufferTimeout = MkBufferTimeout Timeout deriving stock (Eq, Show) @@ -107,7 +106,6 @@ parseBufferTimeout :: f BufferTimeout parseBufferTimeout getNat getTxt = MkBufferTimeout <$> Timeout.parseTimeout getNat getTxt -{-# INLINEABLE parseBufferTimeout #-} -- | Switch for logging read errors data ReportReadErrorsSwitch @@ -381,14 +379,13 @@ defaultCommandLoggingMerged fileLogging cmds = -- | Merges args and toml configs. mergeCommandLogging :: - ( HasCallStack, - MonadThrow m + ( HasCallStack ) => Bool -> NESeq CommandP1 -> CommandLoggingArgs -> Maybe CommandLoggingToml -> - m CommandLoggingMerged + Eff es CommandLoggingMerged mergeCommandLogging fileLogging cmds args mToml = do readStrategy <- guardReadStrategy diff --git a/src/Shrun/Configuration/Data/CommandLogging/PollInterval.hs b/src/Shrun/Configuration/Data/CommandLogging/PollInterval.hs index 077fd04a..d77bd7c2 100644 --- a/src/Shrun/Configuration/Data/CommandLogging/PollInterval.hs +++ b/src/Shrun/Configuration/Data/CommandLogging/PollInterval.hs @@ -28,7 +28,6 @@ instance DecodeTOML PollInterval where parsePollInterval :: (Functor m) => m Natural -> m PollInterval parsePollInterval getNat = MkPollInterval <$> getNat -{-# INLINEABLE parsePollInterval #-} instance Default PollInterval where def = MkPollInterval 10_000 diff --git a/src/Shrun/Configuration/Data/CommandLogging/ReadSize.hs b/src/Shrun/Configuration/Data/CommandLogging/ReadSize.hs index 19d7c649..2cf2baa9 100644 --- a/src/Shrun/Configuration/Data/CommandLogging/ReadSize.hs +++ b/src/Shrun/Configuration/Data/CommandLogging/ReadSize.hs @@ -122,4 +122,3 @@ parseReadSize getTxt = do Left err -> fail $ "Could not convert read-size: " ++ err Right b' -> pure $ MkReadSize b' Left err -> fail $ "Could not parse --command-log-read-size size: " <> unpack err -{-# INLINEABLE parseReadSize #-} diff --git a/src/Shrun/Configuration/Data/CommandLogging/ReadStrategy.hs b/src/Shrun/Configuration/Data/CommandLogging/ReadStrategy.hs index 57ac0427..d21642b7 100644 --- a/src/Shrun/Configuration/Data/CommandLogging/ReadStrategy.hs +++ b/src/Shrun/Configuration/Data/CommandLogging/ReadStrategy.hs @@ -51,7 +51,6 @@ parseReadStrategy getTxt = "'. Expected one of ", readStrategyStr ] -{-# INLINEABLE parseReadStrategy #-} -- | Available 'ReadStrategy' strings. readStrategyStr :: (IsString a) => a diff --git a/src/Shrun/Configuration/Data/ConsoleLogging.hs b/src/Shrun/Configuration/Data/ConsoleLogging.hs index 745c3dbc..250e78d0 100644 --- a/src/Shrun/Configuration/Data/ConsoleLogging.hs +++ b/src/Shrun/Configuration/Data/ConsoleLogging.hs @@ -267,11 +267,11 @@ instance -- | Merges args and toml configs. mergeConsoleLogging :: ( HasCallStack, - MonadTerminal m + Terminal :> es ) => ConsoleLoggingArgs -> Maybe ConsoleLoggingToml -> - m ConsoleLoggingMerged + Eff es ConsoleLoggingMerged mergeConsoleLogging args mToml = do lineTrunc <- configToLineTrunc $ (args ^. #lineTrunc) <>? (toml ^. #lineTrunc) @@ -297,7 +297,6 @@ mergeConsoleLogging args mToml = do argsCommandLogging = args ^. #commandLogging $> True toml = fromMaybe def mToml -{-# INLINEABLE mergeConsoleLogging #-} instance DecodeTOML ConsoleLoggingToml where tomlDecoder = diff --git a/src/Shrun/Configuration/Data/ConsoleLogging/TimerFormat.hs b/src/Shrun/Configuration/Data/ConsoleLogging/TimerFormat.hs index a74e8a06..16fc9f65 100644 --- a/src/Shrun/Configuration/Data/ConsoleLogging/TimerFormat.hs +++ b/src/Shrun/Configuration/Data/ConsoleLogging/TimerFormat.hs @@ -52,7 +52,6 @@ parseTimerFormat getTxt = "prose_compact" -> pure ProseCompact "prose_full" -> pure ProseFull bad -> fail $ "Unrecognized timer-format: " <> unpack bad -{-# INLINEABLE parseTimerFormat #-} -- | Available 'TimerFormat' strings. timerFormatStr :: (IsString a) => a diff --git a/src/Shrun/Configuration/Data/Core.hs b/src/Shrun/Configuration/Data/Core.hs index 68c2424f..4b35d4cc 100644 --- a/src/Shrun/Configuration/Data/Core.hs +++ b/src/Shrun/Configuration/Data/Core.hs @@ -37,7 +37,7 @@ import Shrun.Configuration.Data.Notify qualified as Notify import Shrun.Configuration.Data.WithDisabled ((?)) import Shrun.Configuration.Default (Default (def)) import Shrun.Data.Command (CommandP1) -import Shrun.Notify.DBus (MonadDBus) +import Shrun.Notify.DBus (DBus) import Shrun.Prelude -- | For types that are only guaranteed to exist for Args. Generally this @@ -328,13 +328,12 @@ deriving stock instance Show (CoreConfigP ConfigPhaseMerged) mergeCoreConfig :: ( HasCallStack, - MonadTerminal m, - MonadThrow m + Terminal :> es ) => NESeq CommandP1 -> CoreConfigArgs -> Maybe CoreConfigToml -> - m CoreConfigMerged + Eff es CoreConfigMerged mergeCoreConfig cmds args mToml = do consoleLogging <- mergeConsoleLogging @@ -371,25 +370,23 @@ mergeCoreConfig cmds args mToml = do } where toml = fromMaybe def mToml -{-# INLINEABLE mergeCoreConfig #-} -- | Given a merged CoreConfig, constructs a ConfigEnv and calls the -- continuation. withCoreEnv :: - forall m a. - ( HasCallStack, - MonadDBus m, - MonadFileWriter m, - MonadHandleWriter m, - MonadPathReader m, - MonadPathWriter m, - MonadSTM m, - MonadTerminal m, - MonadThrow m + forall es a. + ( Concurrent :> es, + DBus :> es, + FileWriter :> es, + HandleWriter :> es, + HasCallStack, + PathReader :> es, + PathWriter :> es, + Terminal :> es ) => CoreConfigMerged -> - (CoreConfigEnv -> m a) -> - m a + (CoreConfigEnv -> Eff es a) -> + Eff es a withCoreEnv merged onCoreConfigEnv = do notify <- traverse Notify.toEnv (merged ^. #notify) @@ -405,7 +402,6 @@ withCoreEnv merged onCoreConfigEnv = do notify } in onCoreConfigEnv coreConfigEnv -{-# INLINEABLE withCoreEnv #-} instance Default (CoreConfigP ConfigPhaseArgs) where def = diff --git a/src/Shrun/Configuration/Data/Core/Timeout.hs b/src/Shrun/Configuration/Data/Core/Timeout.hs index 459bb077..9c1f25e8 100644 --- a/src/Shrun/Configuration/Data/Core/Timeout.hs +++ b/src/Shrun/Configuration/Data/Core/Timeout.hs @@ -40,7 +40,6 @@ instance DecodeTOML Timeout where parseTimeout :: (Alternative f, MonadFail f) => f Natural -> f Text -> f Timeout parseTimeout getNat getTxt = (MkTimeout <$> getNat) <|> (getTxt >>= parseTimeoutStr) -{-# INLINEABLE parseTimeout #-} parseTimeoutStr :: (MonadFail f) => Text -> f Timeout parseTimeoutStr txt = case RT.fromString str of @@ -48,4 +47,3 @@ parseTimeoutStr txt = case RT.fromString str of Left err -> fail $ "Error reading time string: " <> err where str = unpack txt -{-# INLINEABLE parseTimeoutStr #-} diff --git a/src/Shrun/Configuration/Data/FileLogging.hs b/src/Shrun/Configuration/Data/FileLogging.hs index 89d5d7d0..8c953680 100644 --- a/src/Shrun/Configuration/Data/FileLogging.hs +++ b/src/Shrun/Configuration/Data/FileLogging.hs @@ -22,8 +22,8 @@ import Data.Bytes sizedFormatterNatural, ) import Data.Text qualified as T -import Effects.FileSystem.HandleWriter (MonadHandleWriter (withBinaryFile)) -import Effects.FileSystem.PathWriter (MonadPathWriter (createDirectoryIfMissing)) +import Effectful.FileSystem.HandleWriter.Static (withBinaryFile) +import Effectful.FileSystem.PathWriter.Static (createDirectoryIfMissing) import GHC.Num (Num (fromInteger)) import Shrun.Configuration.Data.ConfigPhase ( ConfigPhase @@ -476,11 +476,11 @@ instance -- | Merges args and toml configs. mergeFileLogging :: ( HasCallStack, - MonadTerminal m + Terminal :> es ) => FileLoggingArgs -> Maybe FileLoggingToml -> - m (Maybe FileLoggingMerged) + Eff es (Maybe FileLoggingMerged) mergeFileLogging args mToml = for mPath $ \path -> do let toml = fromMaybe (defaultToml path) mToml @@ -542,7 +542,6 @@ mergeFileLogging args mToml = for mPath $ \path -> do (Without, Nothing) -> Nothing (With p, _) -> Just p (_, Just toml) -> Just $ toml ^. #file % #path -{-# INLINEABLE mergeFileLogging #-} instance DecodeTOML FileLoggingToml where tomlDecoder = @@ -564,18 +563,18 @@ type MLogging = Maybe (Tuple3 FileLoggingMerged Handle (TBQueue FileLog)) -- | Given merged FileLogging config, constructs a FileLoggingEnv and calls -- the continuation. withFileLoggingEnv :: - forall m a. + forall es a. ( HasCallStack, - MonadFileWriter m, - MonadHandleWriter m, - MonadPathReader m, - MonadPathWriter m, - MonadSTM m, - MonadTerminal m + Concurrent :> es, + FileWriter :> es, + HandleWriter :> es, + PathReader :> es, + PathWriter :> es, + Terminal :> es ) => Maybe FileLoggingMerged -> - (Maybe FileLoggingEnv -> m a) -> - m a + (Maybe FileLoggingEnv -> Eff es a) -> + Eff es a withFileLoggingEnv mFileLogging onFileLoggingEnv = do let mkEnv :: MLogging -> Maybe FileLoggingEnv mkEnv Nothing = Nothing @@ -594,21 +593,20 @@ withFileLoggingEnv mFileLogging onFileLoggingEnv = do } withMLogging mFileLogging (onFileLoggingEnv . mkEnv) -{-# INLINEABLE withFileLoggingEnv #-} withMLogging :: - forall m a. + forall es a. ( HasCallStack, - MonadFileWriter m, - MonadHandleWriter m, - MonadPathReader m, - MonadPathWriter m, - MonadSTM m, - MonadTerminal m + Concurrent :> es, + FileWriter :> es, + HandleWriter :> es, + PathReader :> es, + PathWriter :> es, + Terminal :> es ) => Maybe FileLoggingMerged -> - (MLogging -> m a) -> - m a + (MLogging -> Eff es a) -> + Eff es a -- 1. No file logging withMLogging Nothing onLogging = onLogging Nothing -- 2. Use the default path. @@ -637,21 +635,25 @@ withMLogging (Just fileLogging) onLogging = do -- If the above command succeeded and deleteOnSuccess is true, delete the -- log file. Otherwise we will not reach here due to withBinaryFile -- rethrowing an exception, so the file will not be deleted. - when (fileLogging ^. #deleteOnSuccess % #boolIso) - $ removeFileIfExists fp + when (fileLogging ^. #deleteOnSuccess % #boolIso) $ do + -- cannot use usual removeFileIfExists for this idiom because that + -- function assumes the same Static/Dynamic status for + -- doesFileExist/removeFile, but require Dynamic doesFileExist and + -- static removeFile + exists <- doesFileExist fp + when exists (removeFile fp) pure result -{-# INLINEABLE withMLogging #-} handleLogFileSize :: ( HasCallStack, - MonadPathReader m, - MonadPathWriter m, - MonadTerminal m + PathReader :> es, + PathWriter :> es, + Terminal :> es ) => FileSizeMode -> OsPath -> - m () + Eff es () handleLogFileSize fileSizeMode fp = do fileSize <- MkBytes @B . unsafeConvertIntegral <$> getFileSize fp case fileSizeMode of @@ -686,23 +688,20 @@ handleLogFileSize fileSizeMode fp = do toDouble :: Integer -> Double toDouble = fromInteger -{-# INLINEABLE handleLogFileSize #-} ensureFileExists :: ( HasCallStack, - MonadFileWriter m, - MonadPathReader m + FileWriter :> es, + PathReader :> es ) => OsPath -> - m () + Eff es () ensureFileExists fp = do exists <- doesFileExist fp unless exists $ writeFileUtf8 fp "" -{-# INLINEABLE ensureFileExists #-} -getShrunXdgState :: (HasCallStack, MonadPathReader m) => m OsPath +getShrunXdgState :: (HasCallStack, PathReader :> es) => Eff es OsPath getShrunXdgState = getXdgState [osp|shrun|] -{-# INLINEABLE getShrunXdgState #-} defaultToml :: FilePathDefault -> FileLoggingToml defaultToml path = diff --git a/src/Shrun/Configuration/Data/FileLogging/FileMode.hs b/src/Shrun/Configuration/Data/FileLogging/FileMode.hs index 02fdf2ab..7f29b7c3 100644 --- a/src/Shrun/Configuration/Data/FileLogging/FileMode.hs +++ b/src/Shrun/Configuration/Data/FileLogging/FileMode.hs @@ -22,7 +22,6 @@ parseFileMode getTxt = "append" -> pure FileModeAppend "write" -> pure FileModeWrite bad -> fail $ "Unrecognized file-mode: " <> unpack bad -{-# INLINEABLE parseFileMode #-} instance Default FileMode where def = FileModeWrite diff --git a/src/Shrun/Configuration/Data/FileLogging/FilePathDefault.hs b/src/Shrun/Configuration/Data/FileLogging/FilePathDefault.hs index 9389ac88..349cc6d8 100644 --- a/src/Shrun/Configuration/Data/FileLogging/FilePathDefault.hs +++ b/src/Shrun/Configuration/Data/FileLogging/FilePathDefault.hs @@ -24,4 +24,3 @@ parseFilePathDefault getTxt = "default" -> pure FPDefault "" -> fail "Empty path given for --file-log" other -> FPManual <$> OsPath.encodeFail (T.unpack other) -{-# INLINEABLE parseFilePathDefault #-} diff --git a/src/Shrun/Configuration/Data/FileLogging/FileSizeMode.hs b/src/Shrun/Configuration/Data/FileLogging/FileSizeMode.hs index 99ab5ddd..2e7c9a15 100644 --- a/src/Shrun/Configuration/Data/FileLogging/FileSizeMode.hs +++ b/src/Shrun/Configuration/Data/FileLogging/FileSizeMode.hs @@ -49,7 +49,6 @@ parseFileSizeMode getTxt = do case U.parseByteText byteTxt of Right b -> pure $ cons b Left err -> fail $ "Could not parse --file-log-size-mode size: " <> unpack err -{-# INLINEABLE parseFileSizeMode #-} instance Default FileSizeMode where def = FileSizeModeWarn $ convert (Proxy @B) defBytes diff --git a/src/Shrun/Configuration/Data/Notify.hs b/src/Shrun/Configuration/Data/Notify.hs index 7388d0b1..cc16f5e6 100644 --- a/src/Shrun/Configuration/Data/Notify.hs +++ b/src/Shrun/Configuration/Data/Notify.hs @@ -46,7 +46,7 @@ import Shrun.Configuration.Data.WithDisabled ) import Shrun.Configuration.Data.WithDisabled qualified as WD import Shrun.Configuration.Default (Default, def) -import Shrun.Notify.DBus (MonadDBus (connectSession)) +import Shrun.Notify.DBus (DBus, connectSession) import Shrun.Prelude -- See NOTE: [Args vs. Toml mandatory fields] @@ -182,11 +182,10 @@ instance DecodeTOML NotifyToml where #if OSX toEnv :: - ( HasCallStack, - MonadThrow m + ( HasCallStack ) => NotifyMerged -> - m NotifyEnv + Eff es NotifyEnv toEnv notifyMerged = case systemMerged of DBus _ -> throwM OsxNotifySystemMismatchDBus NotifySend -> throwM OsxNotifySystemMismatchNotifySend @@ -197,12 +196,11 @@ toEnv notifyMerged = case systemMerged of #else toEnv :: - ( HasCallStack, - MonadDBus m, - MonadThrow m + ( DBus :> es, + HasCallStack ) => NotifyMerged -> - m NotifyEnv + Eff es NotifyEnv toEnv notifyMerged = case systemMerged of AppleScript -> throwM LinuxNotifySystemMismatchAppleScript DBus _ -> mkNotify notifyMerged . DBus <$> connectSession @@ -212,8 +210,6 @@ toEnv notifyMerged = case systemMerged of #endif -{-# INLINEABLE toEnv #-} - mkNotify :: NotifyMerged -> NotifySystemEnv -> NotifyEnv mkNotify notifyToml systemP2 = MkNotifyP diff --git a/src/Shrun/Configuration/Data/Notify/Action.hs b/src/Shrun/Configuration/Data/Notify/Action.hs index 64e07e4e..ed645a47 100644 --- a/src/Shrun/Configuration/Data/Notify/Action.hs +++ b/src/Shrun/Configuration/Data/Notify/Action.hs @@ -38,7 +38,6 @@ parseNotifyAction getTxt = "'. Expected one of ", notifyActionStr ] -{-# INLINEABLE parseNotifyAction #-} -- | Available 'NotifyAction' strings. notifyActionStr :: (IsString a) => a diff --git a/src/Shrun/Configuration/Data/Notify/System.hs b/src/Shrun/Configuration/Data/Notify/System.hs index 9a2c92d2..4b96c058 100644 --- a/src/Shrun/Configuration/Data/Notify/System.hs +++ b/src/Shrun/Configuration/Data/Notify/System.hs @@ -122,7 +122,6 @@ parseNotifySystem getTxt = "'. Expected one of ", notifySystemStr ] -{-# INLINEABLE parseNotifySystem #-} -- | Available 'NotifySystem' strings. notifySystemStr :: (IsString a) => a diff --git a/src/Shrun/Configuration/Data/Notify/Timeout.hs b/src/Shrun/Configuration/Data/Notify/Timeout.hs index c003005f..04580283 100644 --- a/src/Shrun/Configuration/Data/Notify/Timeout.hs +++ b/src/Shrun/Configuration/Data/Notify/Timeout.hs @@ -51,7 +51,6 @@ parseNotifyTimeout getTxt = getTxt >>= \case "never" -> pure NotifyTimeoutNever other -> NotifyTimeoutSeconds <$> U.readStripUnderscores other -{-# INLINEABLE parseNotifyTimeout #-} -- | Available 'NotifyTimeout' strings. notifyTimeoutStr :: (IsString a) => a diff --git a/src/Shrun/Configuration/Data/Truncation.hs b/src/Shrun/Configuration/Data/Truncation.hs index 2e310335..2849a14d 100644 --- a/src/Shrun/Configuration/Data/Truncation.hs +++ b/src/Shrun/Configuration/Data/Truncation.hs @@ -14,7 +14,7 @@ module Shrun.Configuration.Data.Truncation ) where -import Effects.System.Terminal (getTerminalWidth) +import Effectful.Terminal.Dynamic (getTerminalWidth) import Shrun.Configuration.Data.WithDisabled ( WithDisabled ( Disabled, @@ -56,7 +56,6 @@ parseTruncation getNat = do case convertIntegral n of Left err -> fail err Right x -> pure $ MkTruncation x -{-# INLINEABLE parseTruncation #-} -- | Determines command log line truncation behavior. We need a separate -- type from 'Truncation' to add a third option, to detect the terminal size @@ -78,14 +77,12 @@ parseLineTruncation getNat getTxt = Undetected <$> parseTruncation getNat <|> parseDetected getTxt -{-# INLINEABLE parseLineTruncation #-} parseDetected :: (MonadFail m) => m Text -> m LineTruncation parseDetected getTxt = getTxt >>= \case "detect" -> pure Detected other -> fail $ "Wanted other, received: " <> unpack other -{-# INLINEABLE parseDetected #-} decodeCommandNameTrunc :: Decoder (Maybe (Truncation TruncCommandName)) decodeCommandNameTrunc = getFieldOptWith tomlDecoder "command-name-trunc" @@ -96,10 +93,10 @@ decodeLineTrunc = getFieldOptWith tomlDecoder "line-trunc" -- | Maps line trunc config to actual value. configToLineTrunc :: ( HasCallStack, - MonadTerminal m + Terminal :> es ) => WithDisabled LineTruncation -> - m (Maybe (Truncation TruncLine)) + Eff es (Maybe (Truncation TruncLine)) configToLineTrunc Disabled = pure Nothing configToLineTrunc Without = pure Nothing configToLineTrunc (With Detected) = @@ -108,4 +105,3 @@ configToLineTrunc (With Detected) = -- to avoid multiple lines, hence the subtraction. Just . MkTruncation . (\x -> x - 1) <$> getTerminalWidth configToLineTrunc (With (Undetected x)) = pure $ Just x -{-# INLINEABLE configToLineTrunc #-} diff --git a/src/Shrun/Configuration/Env.hs b/src/Shrun/Configuration/Env.hs index 221bfc29..c15cf5fc 100644 --- a/src/Shrun/Configuration/Env.hs +++ b/src/Shrun/Configuration/Env.hs @@ -15,7 +15,7 @@ where import Data.Sequence qualified as Seq import Data.Text qualified as T -import Shrun (runShellT, shrun) +import Shrun (shrun) import Shrun.Configuration (mergeConfig) import Shrun.Configuration.Args.Parsing ( parserInfoArgs, @@ -34,71 +34,63 @@ import Shrun.Configuration.Env.Types config, consoleLogQueue ), - HasConsoleLogging, ) -import Shrun.Logging.MonadRegionLogger (MonadRegionLogger (Region)) -import Shrun.Notify.DBus (MonadDBus) +import Shrun.Logging.RegionLogger (RegionLogger) +import Shrun.Notify (runNotify) +import Shrun.Notify.DBus (DBus) import Shrun.Prelude -import Shrun.ShellT (ShellT) -- | 'withEnv' with 'shrun'. makeEnvAndShrun :: - forall m r. - ( HasCallStack, - HasConsoleLogging (Env r) (Region (ShellT (Env r) m)), - MonadAsync m, - MonadDBus m, - MonadFileReader m, - MonadFileWriter m, - MonadHandleReader m, - MonadHandleWriter m, - MonadIORef m, - MonadOptparse m, - MonadPathReader m, - MonadPathWriter m, - MonadTypedProcess m, - MonadMask m, - MonadSTM m, - MonadRegionLogger m, - MonadTerminal m, - MonadThread m, - MonadTime m + forall r es. + ( Concurrent :> es, + DBus :> es, + FileReader :> es, + FileWriter :> es, + HandleReader :> es, + HandleWriter :> es, + HasCallStack, + IORefE :> es, + Optparse :> es, + PathReader :> es, + PathWriter :> es, + TypedProcess :> es, + RegionLogger r :> es, + Terminal :> es, + Time :> es ) => - m () -makeEnvAndShrun = withEnv @m @r (runShellT shrun) -{-# INLINEABLE makeEnvAndShrun #-} + Eff es () +makeEnvAndShrun = withEnv @r $ \env -> + runReader env (runNotify @r $ shrun @(Env r) @r) -- | Creates an 'Env' from CLI args and TOML config to run with a monadic -- action. withEnv :: - forall m r a. - ( HasCallStack, - MonadDBus m, - MonadFileReader m, - MonadFileWriter m, - MonadHandleWriter m, - MonadOptparse m, - MonadPathReader m, - MonadPathWriter m, - MonadSTM m, - MonadThrow m, - MonadTerminal m + forall r es a. + ( Concurrent :> es, + DBus :> es, + FileReader :> es, + FileWriter :> es, + HandleWriter :> es, + HasCallStack, + Optparse :> es, + PathReader :> es, + PathWriter :> es, + Terminal :> es ) => - (Env r -> m a) -> - m a + (Env r -> Eff es a) -> + Eff es a withEnv onEnv = getMergedConfig >>= flip fromMergedConfig onEnv -{-# INLINEABLE withEnv #-} -- | Creates a 'MergedConfig' from CLI args and TOML config. getMergedConfig :: - ( HasCallStack, - MonadFileReader m, - MonadOptparse m, - MonadPathReader m, - MonadThrow m, - MonadTerminal m + ( FileReader :> es, + HasCallStack, + Optparse :> es, + PathReader :> es, + Terminal :> es ) => - m MergedConfig + Eff es MergedConfig getMergedConfig = do args <- execParser parserInfoArgs @@ -134,22 +126,20 @@ getMergedConfig = do case decode contents of Right cfg -> pure cfg Left tomlErr -> throwM tomlErr -{-# INLINEABLE getMergedConfig #-} fromMergedConfig :: - ( HasCallStack, - MonadDBus m, - MonadFileWriter m, - MonadHandleWriter m, - MonadPathReader m, - MonadPathWriter m, - MonadSTM m, - MonadTerminal m, - MonadThrow m + ( Concurrent :> es, + DBus :> es, + FileWriter :> es, + HandleWriter :> es, + HasCallStack, + PathReader :> es, + PathWriter :> es, + Terminal :> es ) => MergedConfig -> - (Env r -> m a) -> - m a + (Env r -> Eff es a) -> + Eff es a fromMergedConfig cfg onEnv = do completedCommands <- newTVarA Seq.empty anyError <- newTVarA False @@ -168,8 +158,6 @@ fromMergedConfig cfg onEnv = do onEnv env where commands = cfg ^. #commands -{-# INLINEABLE fromMergedConfig #-} -getShrunXdgConfig :: (HasCallStack, MonadPathReader m) => m OsPath +getShrunXdgConfig :: (HasCallStack, PathReader :> es) => Eff es OsPath getShrunXdgConfig = getXdgConfig [osp|shrun|] -{-# INLINEABLE getShrunXdgConfig #-} diff --git a/src/Shrun/Configuration/Env/Types.hs b/src/Shrun/Configuration/Env/Types.hs index 02b12950..d41c358d 100644 --- a/src/Shrun/Configuration/Env/Types.hs +++ b/src/Shrun/Configuration/Env/Types.hs @@ -1,3 +1,4 @@ +{-# LANGUAGE AllowAmbiguousTypes #-} {-# LANGUAGE UndecidableInstances #-} -- | Provides types and typeclasses for our environment. @@ -248,31 +249,31 @@ instance HasCommands (Env r) where -- | Prepends a completed command. prependCompletedCommand :: - ( HasCallStack, + forall env es. + ( Concurrent :> es, + HasCallStack, HasCommands env, - MonadReader env m, - MonadSTM m + Reader env :> es ) => CommandP1 -> - m () + Eff es () prependCompletedCommand command = do - completedCommands <- asks getCompletedCommands + completedCommands <- asks @env getCompletedCommands modifyTVarA' completedCommands (command :<|) -{-# INLINEABLE prependCompletedCommand #-} instance HasAnyError (Env r) where getAnyError = view #anyError -- | Set anyError to 'True'. setAnyErrorTrue :: - ( HasAnyError env, + forall env es. + ( Concurrent :> es, + HasAnyError env, HasCallStack, - MonadReader env m, - MonadSTM m + Reader env :> es ) => - m () -setAnyErrorTrue = asks getAnyError >>= \ref -> writeTVarA ref True -{-# INLINEABLE setAnyErrorTrue #-} + Eff es () +setAnyErrorTrue = asks @env getAnyError >>= \ref -> writeTVarA ref True -- | Class for retrieving the notify config. class HasNotifyConfig env where diff --git a/src/Shrun/Data/Command.hs b/src/Shrun/Data/Command.hs index af8b980c..451b4f47 100644 --- a/src/Shrun/Data/Command.hs +++ b/src/Shrun/Data/Command.hs @@ -12,8 +12,8 @@ where import Data.Hashable (Hashable) import Data.String (IsString (fromString)) import Data.Text qualified as T -import Effects.Process.Typed (ProcessConfig) -import Effects.Process.Typed qualified as P +import Effectful.Process.Typed (ProcessConfig) +import Effectful.Process.Typed qualified as P import Shrun.Prelude -- $setup diff --git a/src/Shrun/IO.hs b/src/Shrun/IO.hs index fa9eb122..0a9d5a11 100644 --- a/src/Shrun/IO.hs +++ b/src/Shrun/IO.hs @@ -1,3 +1,5 @@ +{-# LANGUAGE AllowAmbiguousTypes #-} + -- | Provides the low-level `IO` functions for running shell commands. module Shrun.IO ( -- * Types @@ -11,9 +13,9 @@ where import Data.ByteString.Lazy qualified as BSL import Data.Time.Relative (RelativeTime) -import Effects.Concurrent.Thread (microsleep) -import Effects.Process.Typed qualified as P -import Effects.Time (MonadTime (getMonotonicTime), withTiming) +import Effectful.Concurrent.Static (microsleep) +import Effectful.Process.Typed qualified as P +import Effectful.Time.Dynamic (getMonotonicTime, withTiming) import Shrun.Configuration.Data.CommandLogging ( BufferLength, BufferTimeout, @@ -53,7 +55,7 @@ import Shrun.IO.Handle ) import Shrun.IO.Handle qualified as Handle import Shrun.Logging.Formatting (formatConsoleLog, formatFileLog) -import Shrun.Logging.MonadRegionLogger (MonadRegionLogger (Region, withRegion)) +import Shrun.Logging.RegionLogger (RegionLogger, withRegion) import Shrun.Logging.Types ( Log (MkLog, cmd, lvl, mode, msg), LogLevel (LevelCommand), @@ -82,63 +84,61 @@ data CommandResult -- | Runs the command, returns ('ExitCode', 'Stderr') shExitCode :: + forall env es. ( HasCallStack, HasInit env, - MonadReader env m, - MonadTypedProcess m + Reader env :> es, + TypedProcess :> es ) => CommandP1 -> - m (ExitCode, Stderr) + Eff es (ExitCode, Stderr) shExitCode cmd = do - process <- commandToProcess cmd <$> asks getInit + process <- commandToProcess cmd <$> asks @env getInit (exitCode, _stdout, stderr) <- P.readProcess process pure (exitCode, wrap (MkStderr . ShrunText.fromText) stderr) where wrap f = f . decodeUtf8Lenient . BSL.toStrict -{-# INLINEABLE shExitCode #-} -- | Version of 'shExitCode' that returns 'Left' 'Stderr' if there is a failure, -- 'Right' 'Stdout' otherwise. tryShExitCode :: + forall env es. ( HasCallStack, HasInit env, - MonadReader env m, - MonadTypedProcess m + Reader env :> es, + TypedProcess :> es ) => CommandP1 -> - m (Maybe Stderr) + Eff es (Maybe Stderr) tryShExitCode cmd = - shExitCode cmd <&> \case + shExitCode @env cmd <&> \case (ExitSuccess, _) -> Nothing (ExitFailure _, stderr) -> Just stderr -{-# INLINEABLE tryShExitCode #-} -- | Runs the command, returning the time elapsed along with a possible -- error. tryCommandLogging :: - forall m env. + forall env r es. ( HasAnyError env, HasCallStack, HasCommands env, HasInit env, HasCommandLogging env, HasCommonLogging env, - HasConsoleLogging env (Region m), + HasConsoleLogging env r, HasFileLogging env, - MonadHandleReader m, - MonadIORef m, - MonadMask m, - MonadReader env m, - MonadRegionLogger m, - MonadSTM m, - MonadThread m, - MonadTime m, - MonadTypedProcess m + HandleReader :> es, + IORefE :> es, + Reader env :> es, + RegionLogger r :> es, + Concurrent :> es, + Time :> es, + TypedProcess :> es ) => -- | Command to run. CommandP1 -> -- | Result. - m CommandResult + Eff es CommandResult tryCommandLogging command = do -- NOTE: We do not want tryCommandLogging to throw sync exceptions, as that -- will take down the whole app. tryCommandStream and tryShExitCode should be @@ -157,33 +157,31 @@ tryCommandLogging command = do -- Thus the most reasonable course of action is to let shrun die and print -- the actual error so it can be fixed. - commonLogging <- asks getCommonLogging - (consoleLogging, consoleLogQueue) <- asks getConsoleLogging - mFileLogging <- asks getFileLogging + commonLogging <- asks @env getCommonLogging + (consoleLogging, consoleLogQueue) <- asks @env getConsoleLogging + mFileLogging <- asks @env getFileLogging let keyHide = commonLogging ^. #keyHide let cmdFn = case (consoleLogging ^. #commandLogging, mFileLogging) of -- 1. No CommandLogging and no FileLogging: No streaming at all. - (ConsoleLogCmdOff, Nothing) -> tryShExitCode + (ConsoleLogCmdOff, Nothing) -> tryShExitCode @env -- 3. CommandLogging but no FileLogging. Stream. (ConsoleLogCmdOn, Nothing) -> \cmd -> - withRegion Linear $ \region -> do + withRegion @r Linear $ \region -> do let logFn = logConsole keyHide consoleLogQueue region consoleLogging - {-# INLINEABLE logFn #-} logFn hello - tryCommandStream logFn cmd + tryCommandStream @env logFn cmd -- 3. No CommandLogging but FileLogging: Stream (to file) but no console -- region. (ConsoleLogCmdOff, Just fileLogging) -> \cmd -> do - let logFn :: Log -> m () + let logFn :: Log -> Eff es () logFn = logFile keyHide fileLogging - {-# INLINEABLE logFn #-} logFn hello - tryCommandStream logFn cmd + tryCommandStream @env logFn cmd -- 4. CommandLogging and FileLogging: Stream (to both) and create console -- region. (ConsoleLogCmdOn, Just fileLogging) -> \cmd -> @@ -191,37 +189,33 @@ tryCommandLogging command = do let logFn log = do logConsole keyHide consoleLogQueue region consoleLogging log logFile keyHide fileLogging log - {-# INLINEABLE logFn #-} logFn hello - tryCommandStream logFn cmd - {-# INLINEABLE cmdFn #-} + tryCommandStream @env logFn cmd withTiming (cmdFn command) >>= \case (rt, Nothing) -> do -- update completed commands - prependCompletedCommand command + prependCompletedCommand @env command pure $ CommandSuccess $ U.timeSpecToRelTime rt (rt, Just err) -> do -- update completed commands - prependCompletedCommand command + prependCompletedCommand @env command -- update anyError - setAnyErrorTrue + setAnyErrorTrue @env pure $ CommandFailure (U.timeSpecToRelTime rt) err where logConsole keyHide consoleQueue region consoleLogging log = do let formatted = formatConsoleLog keyHide consoleLogging log writeTBQueueA consoleQueue (LogRegion (log ^. #mode) region formatted) - {-# INLINEABLE logConsole #-} logFile keyHide fileLogging log = do formatted <- formatFileLog keyHide fileLogging log writeTBQueueA (fileLogging ^. #file % #queue) formatted - {-# INLINEABLE logFile #-} hello = MkLog @@ -230,46 +224,44 @@ tryCommandLogging command = do lvl = LevelCommand, mode = LogModeSet } -{-# INLINEABLE tryCommandLogging #-} -- | Similar to 'tryCommand' except we attempt to stream the commands' output -- instead of the usual swallowing. tryCommandStream :: - ( HasInit env, + forall env es. + ( Concurrent :> es, + HasInit env, HasCallStack, HasCommandLogging env, - MonadHandleReader m, - MonadIORef m, - MonadMask m, - MonadReader env m, - MonadThread m, - MonadTime m, - MonadTypedProcess m + HandleReader :> es, + IORefE :> es, + Reader env :> es, + Time :> es, + TypedProcess :> es ) => -- | Function to apply to streamed logs. - (Log -> m ()) -> + (Log -> Eff es ()) -> -- | Command to run. CommandP1 -> -- | Error, if any. Note that this will be 'Just' iff the command exited -- with an error, even if the error message itself is blank. - m (Maybe Stderr) + Eff es (Maybe Stderr) tryCommandStream logFn cmd = do let outSpec = P.createPipe errSpec = P.createPipe procConfig <- - asks getInit + asks @env getInit <&> P.setStderr outSpec . P.setStdout errSpec . commandToProcess cmd (exitCode, finalData) <- - P.withProcessWait procConfig (streamOutput logFn cmd) + P.withProcessWait procConfig (streamOutput @env logFn cmd) pure $ case exitCode of ExitSuccess -> Nothing ExitFailure _ -> Just $ readHandleResultToStderr finalData -{-# INLINEABLE tryCommandStream #-} -- NOTE: This was an attempt to set the buffering so that we could use -- hGetLine. Unfortunately that failed, see Note @@ -282,25 +274,24 @@ tryCommandStream logFn cmd = do -- pure (h, hClose h) streamOutput :: - forall m env. - ( HasCallStack, + forall env es. + ( Concurrent :> es, + HasCallStack, HasCommandLogging env, - MonadCatch m, - MonadHandleReader m, - MonadIORef m, - MonadReader env m, - MonadThread m, - MonadTime m, - MonadTypedProcess m + HandleReader :> es, + IORefE :> es, + Reader env :> es, + Time :> es, + TypedProcess :> es ) => -- | Function to apply to streamed logs. - (Log -> m ()) -> + (Log -> Eff es ()) -> -- | Command that was run. CommandP1 -> -- | Process handle. Process () Handle Handle -> -- | Exit code along w/ any leftover data. - m (ExitCode, ReadHandleResult) + Eff es (Tuple2 ExitCode ReadHandleResult) streamOutput logFn cmd p = do -- NOTE: [Saving final error message] -- @@ -308,7 +299,7 @@ streamOutput logFn cmd p = do -- report it to the user. Programs can be inconsistent where they report -- errors, so we read both stdout and stderr, prioritizing the latter when -- both exist. - commandLogging <- asks getCommandLogging + commandLogging <- asks @env getCommandLogging let bufferLength = commandLogging ^. #bufferLength bufferTimeout = commandLogging ^. #bufferTimeout @@ -317,9 +308,8 @@ streamOutput logFn cmd p = do pollInterval :: Natural pollInterval = commandLogging ^. (#pollInterval % #unPollInterval) - sleepFn :: m () + sleepFn :: Eff es () sleepFn = when (pollInterval /= 0) (microsleep pollInterval) - {-# INLINEABLE sleepFn #-} blockSize :: Int blockSize = commandLogging ^. (#readSize % #unReadSize % _MkBytes) @@ -328,11 +318,12 @@ streamOutput logFn cmd p = do handleToParams :: Handle -> - m + Eff + es ( Tuple3 (IORef ReadHandleResult) (IORef (Maybe UnlinedText)) - (m ReadHandleResult) + (Eff es ReadHandleResult) ) handleToParams = mkHandleParams @@ -424,15 +415,13 @@ streamOutput logFn cmd p = do ] pure (exitCode, finalData) -{-# INLINEABLE streamOutput #-} -- | Create params for reading from the handle. mkHandleParams :: ( HasCallStack, - MonadCatch m, - MonadHandleReader m, - MonadIORef m, - MonadTime m + HandleReader :> es, + IORefE :> es, + Time :> es ) => -- | Read block size. Int -> @@ -450,11 +439,12 @@ mkHandleParams :: -- 2. Ref for previous partial read (only for read-block-line-buffer -- strategy). -- 3. Read function. - m + Eff + es ( Tuple3 (IORef ReadHandleResult) (IORef (Maybe UnlinedText)) - (m ReadHandleResult) + (Eff es ReadHandleResult) ) mkHandleParams blockSize readStrategy bufLength bufTimeout handle = do lastReadRef <- newIORef ReadNoData @@ -470,15 +460,13 @@ mkHandleParams blockSize readStrategy bufLength bufTimeout handle = do in Handle.readHandle (Just outBufferParams) blockSize handle pure (lastReadRef, prevReadRef, readFn) -{-# INLINEABLE mkHandleParams #-} -- | Final read after the process has exited, to retrieve leftover data. -- Only used with the read-block-line-buffer strategy. readFinalWithPrev :: ( HasCallStack, - MonadCatch m, - MonadHandleReader m, - MonadIORef m + HandleReader :> es, + IORefE :> es ) => -- | Block size. Int -> @@ -487,7 +475,7 @@ readFinalWithPrev :: -- | Previous partial read. IORef (Maybe UnlinedText) -> -- | Result. - m ReadHandleResult + Eff es ReadHandleResult readFinalWithPrev blockSize handle prevReadRef = do Handle.readHandleRaw blockSize handle >>= \case -- Do not care about errors here, since we may still have leftover @@ -495,7 +483,6 @@ readFinalWithPrev blockSize handle prevReadRef = do -- here, but it seems minor. Left _ -> Handle.readAndUpdateRefFinal prevReadRef "" Right bs -> Handle.readAndUpdateRefFinal prevReadRef bs -{-# INLINEABLE readFinalWithPrev #-} -- We occasionally get invalid reads here -- usually when the command -- exits -- likely due to a race condition. It would be nice to @@ -507,15 +494,14 @@ readFinalWithPrev blockSize handle prevReadRef = do -- -- See Note [EOF / blocking error] writeLog :: - ( HasCallStack, - MonadIORef m + ( IORefE :> es ) => - (Log -> m ()) -> + (Log -> Eff es ()) -> ReportReadErrorsSwitch -> CommandP1 -> IORef ReadHandleResult -> ReadHandleResult -> - m () + Eff es () writeLog _ _ _ _ ReadNoData = pure () writeLog _ ReportReadErrorsOff _ _ (ReadErr _) = pure () writeLog logFn ReportReadErrorsOn cmd lastReadRef r@(ReadErr messages) = @@ -525,18 +511,16 @@ writeLog logFn reportReadErrors cmd lastReadRef r@(ReadErrSuccess errs successes writeLogHelper logFn cmd lastReadRef r successes writeLog logFn _ cmd lastReadRef r@(ReadSuccess messages) = writeLogHelper logFn cmd lastReadRef r messages -{-# INLINEABLE writeLog #-} writeLogHelper :: - ( HasCallStack, - MonadIORef m + ( IORefE :> es ) => - (Log -> m b) -> + (Log -> Eff es b) -> CommandP1 -> IORef ReadHandleResult -> ReadHandleResult -> NonEmpty UnlinedText -> - m () + Eff es () writeLogHelper logFn cmd lastReadRef handleResult messages = do writeIORef lastReadRef handleResult for_ messages $ \msg -> @@ -547,4 +531,3 @@ writeLogHelper logFn cmd lastReadRef handleResult messages = do lvl = LevelCommand, mode = LogModeSet } -{-# INLINEABLE writeLogHelper #-} diff --git a/src/Shrun/IO/Handle.hs b/src/Shrun/IO/Handle.hs index 8939d334..25ebebd2 100644 --- a/src/Shrun/IO/Handle.hs +++ b/src/Shrun/IO/Handle.hs @@ -16,12 +16,12 @@ import Data.ByteString qualified as BS #if MIN_VERSION_base (4, 19, 0) import Data.List qualified as L #endif -import Effects.FileSystem.HandleReader - ( MonadHandleReader (hIsClosed), - hGetNonBlocking, +import Effectful.FileSystem.HandleReader.Static + ( hGetNonBlocking, + hIsClosed, hIsReadable, ) -import Effects.Time (MonadTime (getMonotonicTime)) +import Effectful.Time.Dynamic (getMonotonicTime) import GHC.Real (RealFrac (floor)) import Shrun.Configuration.Data.CommandLogging import Shrun.Data.Text (UnlinedText) @@ -115,15 +115,14 @@ type BufferParams = -- | Attempts to read from the handle. readHandle :: ( HasCallStack, - MonadCatch m, - MonadHandleReader m, - MonadIORef m, - MonadTime m + HandleReader :> es, + IORefE :> es, + Time :> es ) => Maybe BufferParams -> Int -> Handle -> - m ReadHandleResult + Eff es ReadHandleResult readHandle mBufferParams blockSize handle = do readHandleRaw blockSize handle >>= \case Left err -> @@ -143,18 +142,16 @@ readHandle mBufferParams blockSize handle = do [] -> ReadNoData (x : xs) -> ReadSuccess (x :| xs) Just bufferParams -> readAndUpdateRef bufferParams bs -{-# INLINEABLE readHandle #-} -- | Attempts to read from the handle. Returns Left error or Right -- success. readHandleRaw :: ( HasCallStack, - MonadCatch m, - MonadHandleReader m + HandleReader :> es ) => Int -> Handle -> - m (Either (NonEmpty UnlinedText) ByteString) + Eff es (Either (NonEmpty UnlinedText) ByteString) readHandleRaw blockSize handle = do -- The "nothingIfReady" check and reading step both need to go in the try as -- the former can also throw. @@ -180,7 +177,6 @@ readHandleRaw blockSize handle = do -- should be large enough that we are not likely to cut off a line -- prematurely, but obviously this is best-effort. Right <$> hGetNonBlocking handle blockSize - {-# INLINEABLE readHandle' #-} nothingIfReady = do -- NOTE: This somewhat torturous logic exists for a reason. We want to @@ -204,8 +200,6 @@ readHandleRaw blockSize handle = do if not isReadable then pure $ Just "Handle is not readable" else pure Nothing - {-# INLINEABLE nothingIfReady #-} -{-# INLINEABLE readHandleRaw #-} -- NOTE: [EOF / blocking error] We would like to check hIsEOF (definitely -- causes errors at the end) and probably hReady as well, but these both @@ -214,17 +208,17 @@ readHandleRaw blockSize handle = do -- | General handler for combining reads with previous read data. readAndUpdateRef :: - forall m. + forall es. ( HasCallStack, - MonadIORef m, - MonadTime m + IORefE :> es, + Time :> es ) => -- | Buffer params. BufferParams -> -- | Current read. ByteString -> -- | Result. - m ReadHandleResult + Eff es ReadHandleResult readAndUpdateRef (prevReadRef, bufferLength, bufferTimeout, bufferWriteTimeRef) = readByteStringPrevHandler onNoData @@ -233,7 +227,7 @@ readAndUpdateRef (prevReadRef, bufferLength, bufferTimeout, bufferWriteTimeRef) prevReadRef where -- 1. No data: Send the prevRead if it exists and breaks the thresholds. - onNoData :: m ReadHandleResult + onNoData :: Eff es ReadHandleResult onNoData = readIORef prevReadRef >>= \case @@ -241,11 +235,10 @@ readAndUpdateRef (prevReadRef, bufferLength, bufferTimeout, bufferWriteTimeRef) Just prevRead -> maybeToReadHandleResult <$> prepareSendIfExceedsThresholds (const (pure ())) prevRead - {-# INLINEABLE onNoData #-} -- 2. Partial read: Send the data if it breaks the thresholds, prepending -- prevRead if it exists. - onPartialRead :: UnlinedText -> m ReadHandleResult + onPartialRead :: UnlinedText -> Eff es ReadHandleResult onPartialRead finalPartialRead = readIORef prevReadRef >>= \case Nothing -> @@ -255,10 +248,9 @@ readAndUpdateRef (prevReadRef, bufferLength, bufferTimeout, bufferWriteTimeRef) let combinedRead = prevRead <> finalPartialRead maybeToReadHandleResult <$> prepareSendIfExceedsThresholds updateRef combinedRead - {-# INLINEABLE onPartialRead #-} -- 3. Completed reads and partial read. - onCompletedAndPartialRead :: NonEmpty UnlinedText -> UnlinedText -> m ReadHandleResult + onCompletedAndPartialRead :: NonEmpty UnlinedText -> UnlinedText -> Eff es ReadHandleResult onCompletedAndPartialRead completedReads finalPartialRead = do completedReads' <- mPrependPrevRead prevReadRef completedReads finalPartialResult <- prepareSendIfExceedsThresholds updateRef finalPartialRead @@ -271,7 +263,6 @@ readAndUpdateRef (prevReadRef, bufferLength, bufferTimeout, bufferWriteTimeRef) Nothing -> completedReads' Just finalRead -> completedReads' <> ne finalRead pure $ ReadSuccess totalRead - {-# INLINEABLE onCompletedAndPartialRead #-} -- Turns this text into Just text iff the buffer thresholds are -- exceeded. @@ -279,10 +270,10 @@ readAndUpdateRef (prevReadRef, bufferLength, bufferTimeout, bufferWriteTimeRef) -- Callback for __not__ sending any data. This is used by -- onPartialRead to update its IORef, since the reference will be new. -- onNoData does not need it since the reference is already up-to-date. - (UnlinedText -> m ()) -> + (UnlinedText -> Eff es ()) -> -- The data to check. UnlinedText -> - m (Maybe UnlinedText) + Eff es (Maybe UnlinedText) prepareSendIfExceedsThresholds onNoSend readData = do exceeds <- exceedsThreshold readData if exceeds @@ -294,14 +285,12 @@ readAndUpdateRef (prevReadRef, bufferLength, bufferTimeout, bufferWriteTimeRef) else do onNoSend readData pure Nothing - {-# INLINEABLE prepareSendIfExceedsThresholds #-} - exceedsThreshold :: UnlinedText -> m Bool + exceedsThreshold :: UnlinedText -> Eff es Bool exceedsThreshold t = if bufferExceedsLength t then pure True else bufferExceedsTime - {-# INLINEABLE exceedsThreshold #-} bufferExceedsLength :: UnlinedText -> Bool bufferExceedsLength t = tLen > bufLen @@ -309,7 +298,7 @@ readAndUpdateRef (prevReadRef, bufferLength, bufferTimeout, bufferWriteTimeRef) tLen = ShrunText.length t bufLen = bufferLength ^. #unBufferLength - bufferExceedsTime :: m Bool + bufferExceedsTime :: Eff es Bool bufferExceedsTime = do currTime <- getMonotonicTime bufferWriteTime <- readIORef bufferWriteTimeRef @@ -319,31 +308,25 @@ readAndUpdateRef (prevReadRef, bufferLength, bufferTimeout, bufferWriteTimeRef) pure $ diffTime > bufTimeout where bufTimeout = bufferTimeout ^. #unBufferTimeout % #unTimeout - {-# INLINEABLE bufferExceedsTime #-} resetPrevReadRef' = resetPrevReadRef prevReadRef - {-# INLINEABLE resetPrevReadRef' #-} updateRef = writeIORef prevReadRef . Just - {-# INLINEABLE updateRef #-} maybeToReadHandleResult Nothing = ReadNoData maybeToReadHandleResult (Just read) = ReadSuccess (ne read) - {-# INLINEABLE maybeToReadHandleResult #-} -{-# INLINEABLE readAndUpdateRef #-} -- | Intended for a final read that handles previous read data. readAndUpdateRefFinal :: - forall m. - ( HasCallStack, - MonadIORef m + forall es. + ( IORefE :> es ) => -- | Previous read. IORef (Maybe UnlinedText) -> -- | Current read. ByteString -> -- | Result. - m ReadHandleResult + Eff es ReadHandleResult readAndUpdateRefFinal prevReadRef = readByteStringPrevHandler onNoData @@ -352,63 +335,56 @@ readAndUpdateRefFinal prevReadRef = prevReadRef where -- 1. No data: Final read, so send off prevRead if it exists, and reset the ref. - onNoData :: m ReadHandleResult + onNoData :: Eff es ReadHandleResult onNoData = readIORef prevReadRef >>= \case Nothing -> resetPrevReadRef' $> ReadNoData Just prevRead -> resetPrevReadRef' $> ReadSuccess (ne prevRead) - {-# INLINEABLE onNoData #-} -- 2. Partial read: Combine if prevRead exists, send off result. - onPartialRead :: UnlinedText -> m ReadHandleResult + onPartialRead :: UnlinedText -> Eff es ReadHandleResult onPartialRead finalPartialRead = do readIORef prevReadRef >>= \case Nothing -> resetPrevReadRef' $> ReadSuccess (ne finalPartialRead) Just prevRead -> resetPrevReadRef' $> ReadSuccess (ne $ prevRead <> finalPartialRead) - {-# INLINEABLE onPartialRead #-} -- 3. Completed and partial reads: Combine, send off result. - onCompletedAndPartialRead :: NonEmpty UnlinedText -> UnlinedText -> m ReadHandleResult + onCompletedAndPartialRead :: NonEmpty UnlinedText -> UnlinedText -> Eff es ReadHandleResult onCompletedAndPartialRead completedReads finalPartialRead = do completedReads' <- mPrependPrevRead prevReadRef completedReads resetPrevReadRef' pure $ ReadSuccess $ completedReads' <> ne finalPartialRead - {-# INLINEABLE onCompletedAndPartialRead #-} resetPrevReadRef' = resetPrevReadRef prevReadRef - {-# INLINEABLE resetPrevReadRef' #-} -{-# INLINEABLE readAndUpdateRefFinal #-} mPrependPrevRead :: - (HasCallStack, MonadIORef m) => + (IORefE :> es) => IORef (Maybe UnlinedText) -> NonEmpty UnlinedText -> - m (NonEmpty UnlinedText) + Eff es (NonEmpty UnlinedText) mPrependPrevRead ref cr@(r :| rs) = readIORef ref >>= \case Nothing -> pure cr Just prevRead -> resetPrevReadRef' $> prevRead <> r :| rs where resetPrevReadRef' = resetPrevReadRef ref -{-# INLINEABLE mPrependPrevRead #-} -- | Helper for reading a bytestring and handling a previous, partial read. readByteStringPrevHandler :: - forall m. - ( HasCallStack, - MonadIORef m + forall es. + ( IORefE :> es ) => -- | Callback for no data. - m ReadHandleResult -> + Eff es ReadHandleResult -> -- | Callback for a partial, final read. - (UnlinedText -> m ReadHandleResult) -> + (UnlinedText -> Eff es ReadHandleResult) -> -- | Callback for completed reads _and_ a partial, final read. - (NonEmpty UnlinedText -> UnlinedText -> m ReadHandleResult) -> + (NonEmpty UnlinedText -> UnlinedText -> Eff es ReadHandleResult) -> -- | Reference that stores the previous, partial read. IORef (Maybe UnlinedText) -> -- | The bytestring for the current read. ByteString -> - m ReadHandleResult + Eff es ReadHandleResult readByteStringPrevHandler onNoData onPartialRead @@ -424,7 +400,6 @@ readByteStringPrevHandler (Nothing, Just finalPartialRead) -> onPartialRead finalPartialRead (Just completedReads, Just finalPartialRead) -> onCompletedAndPartialRead completedReads finalPartialRead -{-# INLINEABLE readByteStringPrevHandler #-} -- | Reads a bytestring, distinguishing between _complete_ and _partial_ -- reads. A bytestring is considered _complete_ iff it is terminated with a @@ -467,9 +442,8 @@ readByteString bs = case BS.unsnoc bs of where decodeRead = ShrunText.fromText . decodeUtf8Lenient -resetPrevReadRef :: (HasCallStack, MonadIORef m) => IORef (Maybe a) -> m () +resetPrevReadRef :: (IORefE :> es) => IORef (Maybe a) -> Eff es () resetPrevReadRef prevReadRef = writeIORef prevReadRef Nothing -{-# INLINEABLE resetPrevReadRef #-} -- TODO: Remove once we are past GHC 9.6 unsnoc :: List a -> Maybe (List a, a) @@ -484,7 +458,6 @@ unsnoc = L.unsnoc -- and not to be prone to stack overflows. -- Expressing the recursion via 'foldr' provides for list fusion. unsnoc = foldr (\x -> Just . maybe ([], x) (\(~(a, b)) -> (x : a, b))) Nothing -{-# INLINEABLE unsnoc #-} #endif diff --git a/src/Shrun/Logging.hs b/src/Shrun/Logging.hs index 708509ed..14b9790f 100644 --- a/src/Shrun/Logging.hs +++ b/src/Shrun/Logging.hs @@ -1,3 +1,5 @@ +{-# LANGUAGE AllowAmbiguousTypes #-} + -- | Provides logging functionality. This is a high-level picture of how -- logging works: -- @@ -30,7 +32,6 @@ import Shrun.Configuration.Env.Types HasFileLogging (getFileLogging), ) import Shrun.Logging.Formatting (formatConsoleLog, formatFileLog) -import Shrun.Logging.MonadRegionLogger (MonadRegionLogger (Region)) import Shrun.Logging.Types ( Log, LogRegion (LogRegion), @@ -41,56 +42,56 @@ import Shrun.Prelude -- writes the log to the file queue, if 'Logging'\'s @fileLogging@ is -- present. putRegionLog :: + forall env r es. ( HasCallStack, HasCommonLogging env, - HasConsoleLogging env (Region m), + HasConsoleLogging env r, HasFileLogging env, - MonadReader env m, - MonadSTM m, - MonadTime m + Reader env :> es, + Concurrent :> es, + Time :> es ) => -- | Region. - Region m -> + r -> -- | Log to send. Log -> - m () + Eff es () putRegionLog region lg = do - commonLogging <- asks getCommonLogging - mFileLogging <- asks getFileLogging + commonLogging <- asks @env getCommonLogging + mFileLogging <- asks @env getFileLogging let keyHide = commonLogging ^. #keyHide - regionLogToConsoleQueue region lg + regionLogToConsoleQueue @env region lg for_ mFileLogging (\fl -> logToFileQueue keyHide fl lg) -{-# INLINEABLE putRegionLog #-} -- | Writes the log to the console queue. regionLogToConsoleQueue :: + forall env es r. ( HasCallStack, HasCommonLogging env, - HasConsoleLogging env (Region m), - MonadReader env m, - MonadSTM m + HasConsoleLogging env r, + Reader env :> es, + Concurrent :> es ) => -- | Region. - Region m -> + r -> -- | Log to send. Log -> - m () + Eff es () regionLogToConsoleQueue region log = do - keyHide <- asks (view #keyHide . getCommonLogging) - (consoleLogging, queue) <- asks getConsoleLogging + keyHide <- asks @env (view #keyHide . getCommonLogging) + (consoleLogging, queue) <- asks @env getConsoleLogging let formatted = formatConsoleLog keyHide consoleLogging log writeTBQueueA queue (LogRegion (log ^. #mode) region formatted) -{-# INLINEABLE regionLogToConsoleQueue #-} -- | Writes the log to the file queue. logToFileQueue :: ( HasCallStack, - MonadSTM m, - MonadTime m + Concurrent :> es, + Time :> es ) => -- | How to display the command. KeyHideSwitch -> @@ -98,8 +99,7 @@ logToFileQueue :: FileLoggingEnv -> -- | Log to send. Log -> - m () + Eff es () logToFileQueue keyHide fileLogging log = do formatted <- formatFileLog keyHide fileLogging log writeTBQueueA (fileLogging ^. #file % #queue) formatted -{-# INLINEABLE logToFileQueue #-} diff --git a/src/Shrun/Logging/Formatting.hs b/src/Shrun/Logging/Formatting.hs index 9447660d..8fa67979 100644 --- a/src/Shrun/Logging/Formatting.hs +++ b/src/Shrun/Logging/Formatting.hs @@ -21,7 +21,7 @@ module Shrun.Logging.Formatting where import Data.Text qualified as T -import Effects.Time (getSystemTimeString) +import Effectful.Time.Dynamic (getSystemTimeString) import Shrun.Configuration.Data.CommonLogging.KeyHideSwitch ( KeyHideSwitch (KeyHideOff), ) @@ -96,12 +96,12 @@ maybeApply = maybe id -- | Formats a 'Log' into a 'FileLog'. Applies prefix and timestamp. formatFileLog :: ( HasCallStack, - MonadTime m + Time :> es ) => KeyHideSwitch -> FileLoggingEnv -> Log -> - m FileLog + Eff es FileLog formatFileLog keyHide fileLogging log = do currTime <- getSystemTimeString let timestamp = brackets False (pack currTime) @@ -124,7 +124,6 @@ formatFileLog keyHide fileLogging log = do ] pure $ UnsafeFileLog withTimestamp -{-# INLINEABLE formatFileLog #-} -- | Core formatting, shared by console and file logs. Basic idea: -- diff --git a/src/Shrun/Logging/MonadRegionLogger.hs b/src/Shrun/Logging/MonadRegionLogger.hs deleted file mode 100644 index 526ead24..00000000 --- a/src/Shrun/Logging/MonadRegionLogger.hs +++ /dev/null @@ -1,69 +0,0 @@ --- | Provides functionality for logging to a specific region --- (i.e. for concurrent console logging). -module Shrun.Logging.MonadRegionLogger - ( MonadRegionLogger (..), - ) -where - -import Shrun.Logging.Types.Internal - ( LogMode - ( LogModeAppend, - LogModeFinish, - LogModeSet - ), - ) -import Shrun.Prelude -import System.Console.Regions qualified as Regions - --- | `MonadRegionLogger` is a simple typeclass for abstracting logging functions. -type MonadRegionLogger :: (Type -> Type) -> Constraint -class (Monad m) => MonadRegionLogger m where - -- | The type of the region. This will be ConsoleRegion for production - -- code and () for tests. - type Region m - - -- | Pushes a log to the "global" region. - logGlobal :: (HasCallStack) => Text -> m () - - -- | Pushes a log to the region. - logRegion :: (HasCallStack) => LogMode -> Region m -> Text -> m () - - -- | Runs an @m a@ with a region. - withRegion :: (HasCallStack) => RegionLayout -> (Region m -> m a) -> m a - - -- | Displays the regions. This should wrap whatever top-level logic - -- needs regions. - displayRegions :: (HasCallStack) => m a -> m a - -instance MonadRegionLogger IO where - type Region IO = ConsoleRegion - - logGlobal = putTextLn - {-# INLINEABLE logGlobal #-} - - logRegion LogModeSet cr = Regions.setConsoleRegion cr - logRegion LogModeAppend cr = Regions.appendConsoleRegion cr - logRegion LogModeFinish cr = Regions.finishConsoleRegion cr - {-# INLINEABLE logRegion #-} - - withRegion = Regions.withConsoleRegion - {-# INLINEABLE withRegion #-} - - displayRegions = Regions.displayConsoleRegions - {-# INLINEABLE displayRegions #-} - -instance (MonadRegionLogger m) => MonadRegionLogger (ReaderT env m) where - type Region (ReaderT env m) = Region m - - logGlobal = lift . logGlobal - {-# INLINEABLE logGlobal #-} - - logRegion m r = lift . logRegion m r - {-# INLINEABLE logRegion #-} - - withRegion l f = - ask >>= \e -> lift (withRegion l (\r -> runReaderT (f r) e)) - {-# INLINEABLE withRegion #-} - - displayRegions m = ask >>= \e -> lift (displayRegions $ runReaderT m e) - {-# INLINEABLE displayRegions #-} diff --git a/src/Shrun/Logging/RegionLogger.hs b/src/Shrun/Logging/RegionLogger.hs new file mode 100644 index 00000000..05c0096f --- /dev/null +++ b/src/Shrun/Logging/RegionLogger.hs @@ -0,0 +1,95 @@ +{-# LANGUAGE AllowAmbiguousTypes #-} + +-- | Provides functionality for logging to a specific region +-- (i.e. for concurrent console logging). +module Shrun.Logging.RegionLogger + ( -- * Effect + RegionLogger (..), + logGlobal, + logRegion, + withRegion, + displayRegions, + + -- * Handler + runRegionLogger, + ) +where + +import Shrun.Logging.Types.Internal + ( LogMode + ( LogModeAppend, + LogModeFinish, + LogModeSet + ), + ) +import Shrun.Prelude +import System.Console.Regions qualified as Regions + +type RegionLogger :: Type -> Effect +data RegionLogger r :: Effect where + LogGlobal :: forall r m. Text -> RegionLogger r m () + LogRegion :: forall r m. LogMode -> r -> Text -> RegionLogger r m () + WithRegion :: forall r m a. RegionLayout -> (r -> m a) -> RegionLogger r m a + DisplayRegions :: forall r m a. m a -> RegionLogger r m a + +-- | @since 0.1 +type instance DispatchOf (RegionLogger _) = Dynamic + +runRegionLogger :: + ( r ~ ConsoleRegion, + HasCallStack, + IOE :> es, + Terminal :> es + ) => + Eff (RegionLogger r : es) a -> + Eff es a +runRegionLogger = interpret $ \env -> \case + LogGlobal t -> putTextLn t + LogRegion m r t -> case m of + LogModeSet -> liftIO $ Regions.setConsoleRegion r t + LogModeAppend -> liftIO $ Regions.appendConsoleRegion r t + LogModeFinish -> liftIO $ Regions.finishConsoleRegion r t + WithRegion layout onRegion -> localSeqUnliftIO env $ \runInIO -> + liftIO $ Regions.withConsoleRegion layout (runInIO . onRegion) + DisplayRegions m -> + localSeqUnliftIO env $ \runInIO -> + liftIO $ Regions.displayConsoleRegions (runInIO m) + +logGlobal :: + forall r es. + ( HasCallStack, + RegionLogger r :> es + ) => + Text -> + Eff es () +logGlobal = send . LogGlobal @r + +logRegion :: + forall r es. + ( HasCallStack, + RegionLogger r :> es + ) => + LogMode -> + r -> + Text -> + Eff es () +logRegion m r = send . LogRegion @r m r + +withRegion :: + forall r es a. + ( HasCallStack, + RegionLogger r :> es + ) => + RegionLayout -> + (r -> Eff es a) -> + Eff es a +withRegion l = send . WithRegion @r l + +displayRegions :: + forall r es a. + ( HasCallStack, + RegionLogger r :> es + ) => + Eff es a -> + Eff es a +displayRegions = send . DisplayRegions @r diff --git a/src/Shrun/Notify.hs b/src/Shrun/Notify.hs index 42ac10f4..55969e9f 100644 --- a/src/Shrun/Notify.hs +++ b/src/Shrun/Notify.hs @@ -1,12 +1,20 @@ +{-# LANGUAGE AllowAmbiguousTypes #-} + -- | Module for sending notifications. module Shrun.Notify - ( sendNotif, + ( -- * Primary + sendNotif, + + -- * Handler + runNotify, ) where import DBus.Notify (UrgencyLevel) +import Shrun.Configuration.Data.Notify.System (NotifySystemP (AppleScript, DBus, NotifySend)) import Shrun.Configuration.Env.Types - ( HasAnyError, + ( Env, + HasAnyError, HasCommonLogging, HasConsoleLogging, HasFileLogging, @@ -16,32 +24,34 @@ import Shrun.Configuration.Env.Types import Shrun.Data.Text (UnlinedText) import Shrun.Data.Text qualified as ShrunText import Shrun.Logging qualified as Logging -import Shrun.Logging.MonadRegionLogger (MonadRegionLogger (Region, withRegion)) +import Shrun.Logging.RegionLogger (RegionLogger, withRegion) import Shrun.Logging.Types ( Log (MkLog, cmd, lvl, mode, msg), LogLevel (LevelError), LogMode (LogModeFinish), ) -import Shrun.Notify.MonadNotify - ( MonadNotify (notify), - ShrunNote (MkShrunNote, body, summary, timeout, urgency), - ) +import Shrun.Notify.AppleScript qualified as AppleScript +import Shrun.Notify.DBus (DBus) +import Shrun.Notify.DBus qualified as DBus +import Shrun.Notify.Effect (Notify (Notify), ShrunNote (MkShrunNote, body, summary, timeout, urgency), notify) +import Shrun.Notify.NotifySend qualified as NotifySend import Shrun.Prelude -- | Sends a notification if they are enabled (linux only). Logs any failed -- sends. sendNotif :: + forall env r es. ( HasAnyError env, HasCallStack, HasCommonLogging env, - HasConsoleLogging env (Region m), + HasConsoleLogging env r, HasFileLogging env, HasNotifyConfig env, - MonadNotify m, - MonadReader env m, - MonadRegionLogger m, - MonadSTM m, - MonadTime m + Notify :> es, + Reader env :> es, + RegionLogger r :> es, + Concurrent :> es, + Time :> es ) => -- | Notif summary UnlinedText -> @@ -49,21 +59,20 @@ sendNotif :: UnlinedText -> -- | Notif urgency UrgencyLevel -> - m () + Eff es () sendNotif summary body urgency = do - cfg <- asks getNotifyConfig + cfg <- asks @env getNotifyConfig traverse_ notifyWithErrorLogging (cfg ^? (_Just % #timeout)) where notifyWithErrorLogging timeout = notify (mkNote timeout) >>= \case Nothing -> pure () - Just notifyEx -> withRegion Linear (logEx notifyEx) - {-# INLINEABLE notifyWithErrorLogging #-} + Just notifyEx -> withRegion @r Linear (logEx notifyEx) logEx ex r = do -- set exit code - setAnyErrorTrue - Logging.putRegionLog r + setAnyErrorTrue @env + Logging.putRegionLog @env r $ MkLog { cmd = Nothing, msg = @@ -72,7 +81,6 @@ sendNotif summary body urgency = do lvl = LevelError, mode = LogModeFinish } - {-# INLINEABLE logEx #-} mkNote timeout = MkShrunNote @@ -81,4 +89,22 @@ sendNotif summary body urgency = do urgency, timeout } - {-# INLINEABLE mkNote #-} + +runNotify :: + forall r es a. + ( DBus :> es, + HasCallStack, + Reader (Env r) :> es, + TypedProcess :> es + ) => + Eff (Notify : es) a -> + Eff es a +runNotify = interpret_ $ \case + Notify note -> do + asks @(Env r) (preview (#config % #notify %? #system)) >>= \case + Nothing -> pure Nothing + Just nenv -> sendNote nenv + where + sendNote (DBus client) = DBus.notifyDBus client note + sendNote NotifySend = NotifySend.notifyNotifySend note + sendNote AppleScript = AppleScript.notifyAppleScript note diff --git a/src/Shrun/Notify/AppleScript.hs b/src/Shrun/Notify/AppleScript.hs index 040d1c2d..72dc9fef 100644 --- a/src/Shrun/Notify/AppleScript.hs +++ b/src/Shrun/Notify/AppleScript.hs @@ -5,9 +5,9 @@ module Shrun.Notify.AppleScript where import Data.Text qualified as T -import Effects.Process.Typed qualified as P +import Effectful.Process.Typed qualified as P import Shrun.Configuration.Data.Notify.System (NotifySystemP (AppleScript)) -import Shrun.Notify.MonadNotify +import Shrun.Notify.Effect ( NotifyException (MkNotifyException), ShrunNote, exitFailureToStderr, @@ -15,22 +15,19 @@ import Shrun.Notify.MonadNotify import Shrun.Prelude notifyAppleScript :: - ( HasCallStack, - MonadTypedProcess m + ( TypedProcess :> es ) => ShrunNote -> - m (Maybe NotifyException) + Eff es (Maybe NotifyException) notifyAppleScript note = notify (shrunToAppleScript note) <<&>> \stderr -> MkNotifyException note AppleScript (decodeUtf8Lenient stderr) where - notify :: (HasCallStack, MonadTypedProcess m) => Text -> m (Maybe ByteString) notify = fmap exitFailureToStderr . P.readProcessStderr . P.shell . T.unpack -{-# INLINEABLE notifyAppleScript #-} shrunToAppleScript :: ShrunNote -> Text shrunToAppleScript shrunNote = txt diff --git a/src/Shrun/Notify/DBus.hs b/src/Shrun/Notify/DBus.hs index f6657c8d..4a630994 100644 --- a/src/Shrun/Notify/DBus.hs +++ b/src/Shrun/Notify/DBus.hs @@ -1,6 +1,14 @@ -- | Effect for DBus. module Shrun.Notify.DBus - ( MonadDBus (..), + ( -- * Effect + DBus (..), + connectSession, + notify, + + -- * Handler + runDBus, + + -- * Functions notifyDBus, ) where @@ -17,44 +25,50 @@ import Shrun.Configuration.Data.Notify.Timeout NotifyTimeoutSeconds ), ) -import Shrun.Notify.MonadNotify (NotifyException (MkNotifyException), ShrunNote) +import Shrun.Notify.Effect (NotifyException (MkNotifyException), ShrunNote) import Shrun.Prelude --- | Effect for DBus. -class (Monad m) => MonadDBus m where - -- | Connects to DBus. - connectSession :: (HasCallStack) => m Client +data DBus :: Effect where + ConnectSession :: DBus m Client + Notify :: Client -> Note -> DBus m (Maybe SomeException) + +-- | @since 0.1 +type instance DispatchOf DBus = Dynamic - -- | Sends a notification to DBus. - notify :: (HasCallStack) => Client -> Note -> m (Maybe SomeException) +connectSession :: + ( DBus :> es, + HasCallStack + ) => + Eff es Client +connectSession = send ConnectSession -instance MonadDBus IO where - connectSession = DBusC.connectSession - {-# INLINEABLE connectSession #-} +notify :: + ( DBus :> es, + HasCallStack + ) => + Client -> + Note -> + Eff es (Maybe SomeException) +notify c = send . Notify c - notify client note = - trySync (DBusN.notify client note) <&> \case +runDBus :: (HasCallStack, IOE :> es) => Eff (DBus : es) a -> Eff es a +runDBus = interpret_ $ \case + ConnectSession -> liftIO DBusC.connectSession + Notify client note -> + trySync (liftIO $ DBusN.notify client note) <&> \case Left err -> Just err Right _ -> Nothing - {-# INLINEABLE notify #-} - -instance (MonadDBus m) => MonadDBus (ReaderT env m) where - connectSession = lift connectSession - {-# INLINEABLE connectSession #-} - notify c = lift . notify c - {-# INLINEABLE notify #-} notifyDBus :: - ( HasCallStack, - MonadDBus m + ( DBus :> es, + HasCallStack ) => Client -> ShrunNote -> - m (Maybe NotifyException) + Eff es (Maybe NotifyException) notifyDBus client note = notify client (shrunToDBus note) <<&>> \stderr -> MkNotifyException note (DBus ()) (T.pack $ displayException stderr) -{-# INLINEABLE notifyDBus #-} shrunToDBus :: ShrunNote -> Note shrunToDBus shrunNote = diff --git a/src/Shrun/Notify/MonadNotify.hs b/src/Shrun/Notify/Effect.hs similarity index 89% rename from src/Shrun/Notify/MonadNotify.hs rename to src/Shrun/Notify/Effect.hs index 25423a1f..060db254 100644 --- a/src/Shrun/Notify/MonadNotify.hs +++ b/src/Shrun/Notify/Effect.hs @@ -1,8 +1,10 @@ {-# LANGUAGE UndecidableInstances #-} -- | Provides effects for sending notifications. -module Shrun.Notify.MonadNotify - ( MonadNotify (..), +module Shrun.Notify.Effect + ( -- * Effect + Notify (..), + notify, ShrunNote (..), NotifyException (..), exitFailureToStderr, @@ -109,8 +111,19 @@ instance Exception NotifyException where ] -- | General effect for sending notifications. -class (Monad m) => MonadNotify m where - notify :: (HasCallStack) => ShrunNote -> m (Maybe NotifyException) +data Notify :: Effect where + Notify :: ShrunNote -> Notify m (Maybe NotifyException) + +-- | @since 0.1 +type instance DispatchOf Notify = Dynamic + +notify :: + ( HasCallStack, + Notify :> es + ) => + ShrunNote -> + Eff es (Maybe NotifyException) +notify = send . Notify -- | Maps (ExitCode, stderr) to Just stderr, if the exit code is -- ExitFailure. diff --git a/src/Shrun/Notify/NotifySend.hs b/src/Shrun/Notify/NotifySend.hs index eda6586d..f85b50e6 100644 --- a/src/Shrun/Notify/NotifySend.hs +++ b/src/Shrun/Notify/NotifySend.hs @@ -6,7 +6,7 @@ where import DBus.Notify (UrgencyLevel (Critical, Low, Normal)) import Data.Text qualified as T -import Effects.Process.Typed qualified as P +import Effectful.Process.Typed qualified as P import Shrun.Configuration.Data.Notify.System (NotifySystemP (NotifySend)) import Shrun.Configuration.Data.Notify.Timeout ( NotifyTimeout @@ -14,7 +14,7 @@ import Shrun.Configuration.Data.Notify.Timeout NotifyTimeoutSeconds ), ) -import Shrun.Notify.MonadNotify +import Shrun.Notify.Effect ( NotifyException (MkNotifyException), ShrunNote, exitFailureToStderr, @@ -22,23 +22,22 @@ import Shrun.Notify.MonadNotify import Shrun.Prelude import Shrun.Utils qualified as Utils +-- FIXME: Test the lack of HasCallStack here. + notifyNotifySend :: - ( HasCallStack, - MonadTypedProcess m + ( TypedProcess :> es ) => ShrunNote -> - m (Maybe NotifyException) + Eff es (Maybe NotifyException) notifyNotifySend note = notify (shrunToNotifySend note) <<&>> \stderr -> MkNotifyException note NotifySend (decodeUtf8Lenient stderr) where - notify :: (HasCallStack, MonadTypedProcess m) => Text -> m (Maybe ByteString) notify = fmap exitFailureToStderr . P.readProcessStderr . P.shell . T.unpack -{-# INLINEABLE notifyNotifySend #-} shrunToNotifySend :: ShrunNote -> Text shrunToNotifySend shrunNote = txt diff --git a/src/Shrun/Prelude.hs b/src/Shrun/Prelude.hs index ca547595..821cb168 100644 --- a/src/Shrun/Prelude.hs +++ b/src/Shrun/Prelude.hs @@ -47,6 +47,8 @@ module Shrun.Prelude -- * Debug Utils todo, + unimpl, + unimplWith, traceFile, traceFileLine, @@ -97,11 +99,6 @@ import Control.Monad.Catch as X ) import Control.Monad.Fail as X (MonadFail (fail)) import Control.Monad.IO.Class as X (MonadIO (liftIO)) -import Control.Monad.Reader as X - ( MonadReader (ask, local), - ReaderT (runReaderT), - asks, - ) import Control.Monad.Trans as X (MonadTrans (lift)) import Data.Bifunctor as X (Bifunctor) import Data.Bits (Bits, toIntegralSized) @@ -157,70 +154,104 @@ import Data.Tuple.Experimental as X (Tuple2, Tuple3, Tuple4) import Data.List.NonEmpty qualified as NE import Data.Type.Equality as X (type (~)) import Data.Void as X (Void, absurd) -import Effects.Concurrent.Async as X (MonadAsync) -import Effects.Concurrent.STM as X - ( MonadSTM, - TBQueue, - TVar, +import Effectful as X + ( Dispatch (Dynamic), + DispatchOf, + Eff, + Effect, + IOE, + runEff, + runPureEff, + (:>), + ) +import Effectful.Concurrent as X (Concurrent, runConcurrent) +import Effectful.Concurrent.STM.TBQueue.Static as X + ( TBQueue, flushTBQueueA, - modifyTVarA', newTBQueueA, - newTVarA, readTBQueueA, - readTVarA, writeTBQueueA, + ) +import Effectful.Concurrent.STM.TVar.Static as X + ( TVar, + modifyTVarA', + newTVarA, + readTVarA, writeTVarA, ) -import Effects.Concurrent.Thread as X (MonadThread) -import Effects.FileSystem.FileReader as X - ( MonadFileReader, +import Effectful.Dispatch.Dynamic as X + ( interpret, + interpret_, + localSeqUnliftIO, + reinterpret, + reinterpret_, + send, + ) +import Effectful.Environment as X (Environment, runEnvironment, withArgs) +import Effectful.FileSystem.FileReader.Static as X + ( FileReader, decodeUtf8Lenient, readFileUtf8Lenient, readFileUtf8ThrowM, + runFileReader, ) -import Effects.FileSystem.FileWriter as X - ( MonadFileWriter, +import Effectful.FileSystem.FileWriter.Static as X + ( FileWriter, appendFileUtf8, + runFileWriter, writeFileUtf8, ) -import Effects.FileSystem.HandleReader as X (MonadHandleReader) -import Effects.FileSystem.HandleWriter as X - ( MonadHandleWriter (hClose, hFlush, openBinaryFile), +import Effectful.FileSystem.HandleReader.Static as X + ( HandleReader, + runHandleReader, + ) +import Effectful.FileSystem.HandleWriter.Static as X + ( HandleWriter, + hClose, + hFlush, hPutUtf8, + openBinaryFile, + runHandleWriter, ) -import Effects.FileSystem.PathReader as X - ( MonadPathReader (doesDirectoryExist, doesFileExist, getFileSize), +import Effectful.FileSystem.PathReader.Dynamic as X + ( PathReader, + doesDirectoryExist, + doesFileExist, + getFileSize, getXdgConfig, getXdgState, + runPathReader, ) -import Effects.FileSystem.PathWriter as X - ( MonadPathWriter, +import Effectful.FileSystem.PathWriter.Static as X + ( PathWriter, removeDirectoryIfExists, removeFile, removeFileIfExists, + runPathWriter, ) -import Effects.IORef as X +import Effectful.IORef.Static as X ( IORef, - MonadIORef - ( atomicModifyIORef', - modifyIORef', - newIORef, - readIORef, - writeIORef - ), + IORefE, + atomicModifyIORef', + modifyIORef', + newIORef, + readIORef, + runIORef, + writeIORef, ) -import Effects.Optparse as X (MonadOptparse (execParser)) -import Effects.Process.Typed as X (MonadTypedProcess, Process) -import Effects.System.Environment as X (MonadEnv (withArgs)) -import Effects.System.Terminal as X - ( MonadTerminal, +import Effectful.Optparse.Static as X (Optparse, execParser, runOptparse) +import Effectful.Process.Typed as X (Process, TypedProcess, runTypedProcess) +import Effectful.Reader.Static as X (Reader, ask, asks, runReader) +import Effectful.Terminal.Dynamic as X + ( Terminal, putStr, putStrLn, putText, putTextLn, + runTerminal, ) -import Effects.Time as X (MonadTime) -import FileSystem.OsPath as X (OsPath, decodeLenient, osp, ()) +import Effectful.Time.Dynamic as X (Time, runTime) +import FileSystem.OsPath as X (OsPath, decodeLenient, osp, ospPathSep, ()) import FileSystem.OsPath qualified as OsPath import FileSystem.UTF8 as X (decodeUtf8) import GHC.Enum as X (Bounded (maxBound, minBound), Enum (toEnum)) @@ -282,6 +313,7 @@ import Optics.Core.Extras as X (is) import System.Console.Regions as X (ConsoleRegion, RegionLayout (Linear)) import System.Exit as X (ExitCode (ExitFailure, ExitSuccess)) import System.IO as X (FilePath, Handle, IO, IOMode (AppendMode, WriteMode), print) +import System.IO qualified as IO import System.IO.Unsafe (unsafePerformIO) import TOML as X ( DecodeTOML (tomlDecoder), @@ -330,7 +362,6 @@ headMaybe = foldr (\x _ -> Just x) Nothing -- | From foldable. fromFoldable :: (Foldable f) => a -> f a -> a fromFoldable x = fromMaybe x . headMaybe -{-# INLINEABLE fromFoldable #-} -- | Lifted fmap. -- @@ -428,10 +459,29 @@ todo :: forall {r :: RuntimeRep} (a :: TYPE r). (HasCallStack) => a todo = raise# (errorCallWithCallStackException "Prelude.todo: not yet implemented" ?callStack) {-# WARNING todo "todo remains in code" #-} +unimpl :: forall {r :: RuntimeRep} (a :: TYPE r). (HasCallStack) => a +unimpl = + raise# + ( errorCallWithCallStackException + "Prelude.unimpl: intentionally unimplemented" + ?callStack + ) + +unimplWith :: forall {r :: RuntimeRep} (a :: TYPE r). (HasCallStack) => String -> a +unimplWith str = + raise# + ( errorCallWithCallStackException + ("Prelude.unimplWith: intentionally unimplemented: " ++ str) + ?callStack + ) + traceFile :: FilePath -> Text -> a -> a traceFile path txt x = writeFn `seq` x where - io = appendFileUtf8 (OsPath.unsafeEncode path) txt + io = + runEff $ + runFileWriter $ + appendFileUtf8 (OsPath.unsafeEncode path) txt writeFn = unsafePerformIO io traceFileLine :: FilePath -> Text -> a -> a @@ -445,7 +495,7 @@ setUncaughtExceptionHandlerDisplay = Just ExitSuccess -> pure () -- for command failures Just (ExitFailure _) -> pure () - Nothing -> putStrLn $ displayException ex + Nothing -> IO.putStrLn $ displayException ex onJust :: b -> Maybe a -> (a -> b) -> b onJust x m f = maybe x f m diff --git a/src/Shrun/ShellT.hs b/src/Shrun/ShellT.hs deleted file mode 100644 index d47282d3..00000000 --- a/src/Shrun/ShellT.hs +++ /dev/null @@ -1,76 +0,0 @@ -{-# LANGUAGE UndecidableInstances #-} - --- | Provides the 'ShellT' monad transformer. -module Shrun.ShellT - ( ShellT, - runShellT, - ) -where - -import Shrun.Configuration.Data.Notify.System - ( NotifySystemP (AppleScript, DBus, NotifySend), - ) -import Shrun.Configuration.Env.Types (Env) -import Shrun.Logging.MonadRegionLogger (MonadRegionLogger) -import Shrun.Notify.AppleScript qualified as AppleScript -import Shrun.Notify.DBus (MonadDBus) -import Shrun.Notify.DBus qualified as DBus -import Shrun.Notify.MonadNotify (MonadNotify (notify)) -import Shrun.Notify.NotifySend qualified as NotifySend -import Shrun.Prelude - --- | `ShellT` is the main application type that runs shell commands. -type ShellT :: Type -> (Type -> Type) -> Type -> Type -newtype ShellT env m a = MkShellT (ReaderT env m a) - deriving - ( Functor, - Applicative, - Monad, - MonadAsync, - MonadDBus, - MonadCatch, - MonadFileReader, - MonadFileWriter, - MonadHandleReader, - MonadHandleWriter, - MonadIO, - MonadIORef, - MonadMask, - MonadPathWriter, - MonadTypedProcess, - MonadReader env, - MonadSTM, - MonadThread, - MonadTime, - MonadThrow - ) - via (ReaderT env m) - --- | Runs a 'ShellT' with the given @env@. -runShellT :: forall m env a. ShellT env m a -> env -> m a -runShellT (MkShellT rdr) = runReaderT rdr -{-# INLINEABLE runShellT #-} - --- Concrete Env here so we can vary our logging logic with other envs --- (i.e. in tests). - --- Can't use @deriving via m@ due to a bug: GHC version 9.2.5: No skolem info:@. --- https://gitlab.haskell.org/ghc/ghc/-/issues/15376 - -deriving newtype instance (MonadRegionLogger m) => MonadRegionLogger (ShellT (Env r) m) - -instance - ( MonadDBus m, - MonadTypedProcess m - ) => - MonadNotify (ShellT (Env r) m) - where - notify note = - asks (preview (#config % #notify %? #system)) >>= \case - Nothing -> pure Nothing - Just nenv -> sendNote nenv - where - sendNote (DBus client) = DBus.notifyDBus client note - sendNote NotifySend = NotifySend.notifyNotifySend note - sendNote AppleScript = AppleScript.notifyAppleScript note - {-# INLINEABLE notify #-} diff --git a/src/Shrun/Utils.hs b/src/Shrun/Utils.hs index 7c6f3723..a5580de0 100644 --- a/src/Shrun/Utils.hs +++ b/src/Shrun/Utils.hs @@ -9,7 +9,7 @@ module Shrun.Utils stripControlSmart, escapeDoubleQuotes, - -- * MonadTime Utils + -- * Time Utils diffTime, timeSpecToRelTime, foldMap1, @@ -34,7 +34,7 @@ import Data.Text.Lazy qualified as TL import Data.Text.Lazy.Builder (Builder) import Data.Text.Lazy.Builder qualified as TLB import Data.Time.Relative (RelativeTime, fromSeconds) -import Effects.Time (TimeSpec, diffTimeSpec) +import Effectful.Time.Dynamic (TimeSpec, diffTimeSpec) import GHC.Exts (IsList (fromList)) import Shrun.Data.Text (UnlinedText) import Shrun.Data.Text qualified as ShrunText @@ -47,7 +47,7 @@ import Text.Read qualified as TR -- >>> import Data.List.NonEmpty (NonEmpty (..)) -- >>> import Data.Semigroup (Sum (..)) -- >>> import Data.Text qualified as T --- >>> import Effects.Time (TimeSpec (..)) +-- >>> import Effectful.Time.Dynamic (TimeSpec (..)) -- >>> import Shrun.Prelude -- | For given \(x, y\), returns the absolute difference \(|x - y|\) @@ -81,7 +81,6 @@ timeSpecToRelTime = fromSeconds . view #sec -- 1 :| [2,3,4] foldMap1 :: (Foldable f, Semigroup s) => (a -> s) -> a -> f a -> s foldMap1 f x xs = foldr (\b g y -> f y <> g b) f xs x -{-# INLINEABLE foldMap1 #-} -- | Wrapper for 'Text'\'s 'T.breakOn' that differs in that: -- @@ -265,7 +264,6 @@ parseByteText txt = -- | Runs the action when it is 'Left'. whenLeft :: (Applicative f) => Either a b -> (a -> f ()) -> f () whenLeft e action = either action (const (pure ())) e -{-# INLINEABLE whenLeft #-} -- | @whileM_ mb ma@ executes @ma@ as long as @mb@ returns 'True'. whileM_ :: (Monad m) => m Bool -> m a -> m () @@ -275,7 +273,6 @@ whileM_ mb ma = go mb >>= \case True -> ma *> go False -> pure () -{-# INLINEABLE whileM_ #-} -- | Executes the monadic action until we receive a 'Just', returning the -- value. @@ -286,7 +283,6 @@ untilJust m = go m >>= \case Nothing -> go Just x -> pure x -{-# INLINEABLE untilJust #-} {- HLINT ignore unsafeListToNESeq "Redundant bracket" -} @@ -318,4 +314,3 @@ readStripUnderscores t = case TR.readEither s of where noUnderscores = T.replace "_" "" t s = T.unpack noUnderscores -{-# INLINEABLE readStripUnderscores #-} diff --git a/stack.yaml b/stack.yaml index ff7a2fc6..3430bca5 100644 --- a/stack.yaml +++ b/stack.yaml @@ -4,8 +4,12 @@ packages: ghc-options: "$locals": -Wall -Wcompat -Widentities -Wincomplete-record-updates -Wincomplete-uni-patterns -Wmissing-deriving-strategies -Wmissing-export-lists -Wmissing-exported-signatures -Wmissing-home-modules -Wpartial-fields -Wprepositive-qualified-module -Wredundant-constraints -Wunused-binds -Wunused-packages -Wunused-type-patterns -Wno-deprecations -Wno-unticked-promoted-constructors extra-deps: + - effectful-2.5.0.0@sha256:b6e421caf3cd70ab5cf837fc86a3c370240219ca73178629aee1dc7c31f3f219,7432 + - effectful-core-2.5.0.0@sha256:a34cf1f3b33cf77314d54baec81b61b1c98c67dacb1123605fd7441943e2d904,4203 - env-guard-0.2@sha256:99b89cde1ed6d599880dfbc72b2c9a75ced57b7800a70dcb57d3e3e89e42184c,1312 + - strict-mutable-base-1.1.0.0@sha256:b1c039f6b179aedb420a90cbe15d3c3e78fbaaa7146ed02700b84c6018ee734f,1430 - text-display-0.0.5.2@sha256:6e6a5bf1c83dfa6c34692ed5d8ea87f1bd385984309b42c302f2156f4d82477b,2670 + - typed-process-effectful-1.0.0.3@sha256:83de77e159986022eea66b9fb20812f9de7b27c951cef4cee11608c6b24a80ee,2092 - git: https://github.com/tbidne/algebra-simple.git commit: f8590486ec0fc66acf7db20308e1ed6993a52151 - git: https://github.com/tbidne/bounds.git @@ -14,20 +18,18 @@ extra-deps: commit: 9ecb81e4a16f62736dbe7f90cb1983e7212b0c0f - git: https://github.com/tbidne/fs-utils.git commit: 5406cea74491f382478e70734535c62fe6deef7d - - git: https://github.com/tbidne/monad-effects.git - commit: 8021f9a0855e644d91b73e6b2bcf20406ebbebb8 + - git: https://github.com/tbidne/effectful-effects.git + commit: 3ba8c43901087915bc9418c8ed095a7fad4f8ac1 subdirs: - - lib/effects-async - - lib/effects-env - - lib/effects-fs - - lib/effects-ioref - - lib/effects-optparse - - lib/effects-stm - - lib/effects-time - - lib/effects-terminal - - lib/effects-thread - - lib/effects-typed-process - - lib/effects-unix-compat + - lib/concurrent-effectful + - lib/environment-effectful + - lib/fs-effectful + - lib/ioref-effectful + - lib/optparse-effectful + - lib/stm-effectful + - lib/time-effectful + - lib/terminal-effectful + - lib/unix-compat-effectful - git: https://github.com/tbidne/relative-time.git commit: b3be9b3b904059671ef07dbcbb11b8c04d50ddde - git: https://github.com/tbidne/si-bytes.git diff --git a/stack.yaml.lock b/stack.yaml.lock index c822c542..43bd5c02 100644 --- a/stack.yaml.lock +++ b/stack.yaml.lock @@ -4,6 +4,20 @@ # https://docs.haskellstack.org/en/stable/lock_files packages: +- completed: + hackage: effectful-2.5.0.0@sha256:b6e421caf3cd70ab5cf837fc86a3c370240219ca73178629aee1dc7c31f3f219,7432 + pantry-tree: + sha256: ed8bf4a92bb6dd289742db4553c75ee1c66e5b0291eb1fd0739156e6d59d63b0 + size: 3409 + original: + hackage: effectful-2.5.0.0@sha256:b6e421caf3cd70ab5cf837fc86a3c370240219ca73178629aee1dc7c31f3f219,7432 +- completed: + hackage: effectful-core-2.5.0.0@sha256:a34cf1f3b33cf77314d54baec81b61b1c98c67dacb1123605fd7441943e2d904,4203 + pantry-tree: + sha256: aaa0b924bed66dc27fe685c9384abd9a073d17e238882d2c9ae43d49dbb67fd2 + size: 2474 + original: + hackage: effectful-core-2.5.0.0@sha256:a34cf1f3b33cf77314d54baec81b61b1c98c67dacb1123605fd7441943e2d904,4203 - completed: hackage: env-guard-0.2@sha256:99b89cde1ed6d599880dfbc72b2c9a75ced57b7800a70dcb57d3e3e89e42184c,1312 pantry-tree: @@ -11,6 +25,13 @@ packages: size: 419 original: hackage: env-guard-0.2@sha256:99b89cde1ed6d599880dfbc72b2c9a75ced57b7800a70dcb57d3e3e89e42184c,1312 +- completed: + hackage: strict-mutable-base-1.1.0.0@sha256:b1c039f6b179aedb420a90cbe15d3c3e78fbaaa7146ed02700b84c6018ee734f,1430 + pantry-tree: + sha256: 72f03d9f5f5ad68f71e3405f8060b7a1b0875cd3f6a73ac52b8b2f091ae984d2 + size: 439 + original: + hackage: strict-mutable-base-1.1.0.0@sha256:b1c039f6b179aedb420a90cbe15d3c3e78fbaaa7146ed02700b84c6018ee734f,1430 - completed: hackage: text-display-0.0.5.2@sha256:6e6a5bf1c83dfa6c34692ed5d8ea87f1bd385984309b42c302f2156f4d82477b,2670 pantry-tree: @@ -18,6 +39,13 @@ packages: size: 3364 original: hackage: text-display-0.0.5.2@sha256:6e6a5bf1c83dfa6c34692ed5d8ea87f1bd385984309b42c302f2156f4d82477b,2670 +- completed: + hackage: typed-process-effectful-1.0.0.3@sha256:83de77e159986022eea66b9fb20812f9de7b27c951cef4cee11608c6b24a80ee,2092 + pantry-tree: + sha256: b82047d4da54e0c58c01e5395bf30862dcae37cbf9780f0cd3fac84e0b061c4b + size: 404 + original: + hackage: typed-process-effectful-1.0.0.3@sha256:83de77e159986022eea66b9fb20812f9de7b27c951cef4cee11608c6b24a80ee,2092 - completed: commit: f8590486ec0fc66acf7db20308e1ed6993a52151 git: https://github.com/tbidne/algebra-simple.git @@ -63,148 +91,122 @@ packages: commit: 5406cea74491f382478e70734535c62fe6deef7d git: https://github.com/tbidne/fs-utils.git - completed: - commit: 8021f9a0855e644d91b73e6b2bcf20406ebbebb8 - git: https://github.com/tbidne/monad-effects.git - name: effects-async - pantry-tree: - sha256: 3ca9d0da7ec21b1763c73bec4fbc1d9256d35bf5e3afb47aa55798461fd0e8f5 - size: 236 - subdir: lib/effects-async - version: '0.1' - original: - commit: 8021f9a0855e644d91b73e6b2bcf20406ebbebb8 - git: https://github.com/tbidne/monad-effects.git - subdir: lib/effects-async -- completed: - commit: 8021f9a0855e644d91b73e6b2bcf20406ebbebb8 - git: https://github.com/tbidne/monad-effects.git - name: effects-env + commit: 3ba8c43901087915bc9418c8ed095a7fad4f8ac1 + git: https://github.com/tbidne/effectful-effects.git + name: concurrent-effectful pantry-tree: - sha256: cea13c54356657f05795bb9f40f719b75750d68d0870a128a82884944f5be906 - size: 235 - subdir: lib/effects-env + sha256: 2b36563242f4ae94434574000914cb374000665bae8b182a84aea5b4b5b68e19 + size: 245 + subdir: lib/concurrent-effectful version: '0.1' original: - commit: 8021f9a0855e644d91b73e6b2bcf20406ebbebb8 - git: https://github.com/tbidne/monad-effects.git - subdir: lib/effects-env + commit: 3ba8c43901087915bc9418c8ed095a7fad4f8ac1 + git: https://github.com/tbidne/effectful-effects.git + subdir: lib/concurrent-effectful - completed: - commit: 8021f9a0855e644d91b73e6b2bcf20406ebbebb8 - git: https://github.com/tbidne/monad-effects.git - name: effects-fs + commit: 3ba8c43901087915bc9418c8ed095a7fad4f8ac1 + git: https://github.com/tbidne/effectful-effects.git + name: environment-effectful pantry-tree: - sha256: f476e624093ce8b4bd058328d797e7f3d5ee85e766e2bc7295ba793df83cb8c7 - size: 816 - subdir: lib/effects-fs + sha256: 500956cfe859c56f29a56a5d5e6edd5cbf75548f621f1035d0a8e6ec52421aba + size: 398 + subdir: lib/environment-effectful version: '0.1' original: - commit: 8021f9a0855e644d91b73e6b2bcf20406ebbebb8 - git: https://github.com/tbidne/monad-effects.git - subdir: lib/effects-fs + commit: 3ba8c43901087915bc9418c8ed095a7fad4f8ac1 + git: https://github.com/tbidne/effectful-effects.git + subdir: lib/environment-effectful - completed: - commit: 8021f9a0855e644d91b73e6b2bcf20406ebbebb8 - git: https://github.com/tbidne/monad-effects.git - name: effects-ioref + commit: 3ba8c43901087915bc9418c8ed095a7fad4f8ac1 + git: https://github.com/tbidne/effectful-effects.git + name: fs-effectful pantry-tree: - sha256: 8dee29d4e5ee01399ff19635716fa30d47f65d36c63965e1512d552d090c60d8 - size: 224 - subdir: lib/effects-ioref + sha256: b13b75f69f4d5b4e3fd8703a125aeec496eaaf160ff8a559951dbd41b4250007 + size: 1494 + subdir: lib/fs-effectful version: '0.1' original: - commit: 8021f9a0855e644d91b73e6b2bcf20406ebbebb8 - git: https://github.com/tbidne/monad-effects.git - subdir: lib/effects-ioref + commit: 3ba8c43901087915bc9418c8ed095a7fad4f8ac1 + git: https://github.com/tbidne/effectful-effects.git + subdir: lib/fs-effectful - completed: - commit: 8021f9a0855e644d91b73e6b2bcf20406ebbebb8 - git: https://github.com/tbidne/monad-effects.git - name: effects-optparse + commit: 3ba8c43901087915bc9418c8ed095a7fad4f8ac1 + git: https://github.com/tbidne/effectful-effects.git + name: ioref-effectful pantry-tree: - sha256: 4128b61487c50d19b001fa09a42efc161fcb498d57725328ddc148e652dbe075 - size: 230 - subdir: lib/effects-optparse - version: '0.1' - original: - commit: 8021f9a0855e644d91b73e6b2bcf20406ebbebb8 - git: https://github.com/tbidne/monad-effects.git - subdir: lib/effects-optparse -- completed: - commit: 8021f9a0855e644d91b73e6b2bcf20406ebbebb8 - git: https://github.com/tbidne/monad-effects.git - name: effects-stm - pantry-tree: - sha256: 9892ad01ca527fa7f875cd12dc0c2d2be7fbe5b1e8d314ba586159e53c68d75d - size: 231 - subdir: lib/effects-stm + sha256: 203e5c893a6c7b52b161279f41e9578f03b5c19dcbe07c6ac03c963b8843068a + size: 235 + subdir: lib/ioref-effectful version: '0.1' original: - commit: 8021f9a0855e644d91b73e6b2bcf20406ebbebb8 - git: https://github.com/tbidne/monad-effects.git - subdir: lib/effects-stm + commit: 3ba8c43901087915bc9418c8ed095a7fad4f8ac1 + git: https://github.com/tbidne/effectful-effects.git + subdir: lib/ioref-effectful - completed: - commit: 8021f9a0855e644d91b73e6b2bcf20406ebbebb8 - git: https://github.com/tbidne/monad-effects.git - name: effects-time + commit: 3ba8c43901087915bc9418c8ed095a7fad4f8ac1 + git: https://github.com/tbidne/effectful-effects.git + name: optparse-effectful pantry-tree: - sha256: 1219132a44f027ea7080029eddf1caea1d46ea2c916c8b26b9be9f1e09ac07be - size: 281 - subdir: lib/effects-time + sha256: 02581a790c2046e3608be1e09b38a064a55032046191e933d3d7a04bc75cabe0 + size: 386 + subdir: lib/optparse-effectful version: '0.1' original: - commit: 8021f9a0855e644d91b73e6b2bcf20406ebbebb8 - git: https://github.com/tbidne/monad-effects.git - subdir: lib/effects-time + commit: 3ba8c43901087915bc9418c8ed095a7fad4f8ac1 + git: https://github.com/tbidne/effectful-effects.git + subdir: lib/optparse-effectful - completed: - commit: 8021f9a0855e644d91b73e6b2bcf20406ebbebb8 - git: https://github.com/tbidne/monad-effects.git - name: effects-terminal + commit: 3ba8c43901087915bc9418c8ed095a7fad4f8ac1 + git: https://github.com/tbidne/effectful-effects.git + name: stm-effectful pantry-tree: - sha256: e72cef5145c99c24bf1a4cea69e69370b67fe8d702dab885e9d4f8671230eba3 - size: 237 - subdir: lib/effects-terminal + sha256: b77460f176f0baa32d2b5da1b34d8319e9ff40a242d6a592218df4f5c715ea33 + size: 333 + subdir: lib/stm-effectful version: '0.1' original: - commit: 8021f9a0855e644d91b73e6b2bcf20406ebbebb8 - git: https://github.com/tbidne/monad-effects.git - subdir: lib/effects-terminal + commit: 3ba8c43901087915bc9418c8ed095a7fad4f8ac1 + git: https://github.com/tbidne/effectful-effects.git + subdir: lib/stm-effectful - completed: - commit: 8021f9a0855e644d91b73e6b2bcf20406ebbebb8 - git: https://github.com/tbidne/monad-effects.git - name: effects-thread + commit: 3ba8c43901087915bc9418c8ed095a7fad4f8ac1 + git: https://github.com/tbidne/effectful-effects.git + name: time-effectful pantry-tree: - sha256: 13c21fbeb95dbc296bec59267269adf63409a3451e93658f1b97b2fcb56e214a - size: 237 - subdir: lib/effects-thread + sha256: 53013b38c52689da9245df183d25751c94e1da90caf0044fcb79ac6bdd06af1f + size: 501 + subdir: lib/time-effectful version: '0.1' original: - commit: 8021f9a0855e644d91b73e6b2bcf20406ebbebb8 - git: https://github.com/tbidne/monad-effects.git - subdir: lib/effects-thread + commit: 3ba8c43901087915bc9418c8ed095a7fad4f8ac1 + git: https://github.com/tbidne/effectful-effects.git + subdir: lib/time-effectful - completed: - commit: 8021f9a0855e644d91b73e6b2bcf20406ebbebb8 - git: https://github.com/tbidne/monad-effects.git - name: effects-typed-process + commit: 3ba8c43901087915bc9418c8ed095a7fad4f8ac1 + git: https://github.com/tbidne/effectful-effects.git + name: terminal-effectful pantry-tree: - sha256: 2f2b68bc84d67257705cce6f8125dca2ea3d3459857e85b10edac64ea2621bc8 - size: 240 - subdir: lib/effects-typed-process + sha256: 0836b417698eadca8927d6f1c8f6c5e07da1ce4bc63b6bcb1357bdace2b04f59 + size: 315 + subdir: lib/terminal-effectful version: '0.1' original: - commit: 8021f9a0855e644d91b73e6b2bcf20406ebbebb8 - git: https://github.com/tbidne/monad-effects.git - subdir: lib/effects-typed-process + commit: 3ba8c43901087915bc9418c8ed095a7fad4f8ac1 + git: https://github.com/tbidne/effectful-effects.git + subdir: lib/terminal-effectful - completed: - commit: 8021f9a0855e644d91b73e6b2bcf20406ebbebb8 - git: https://github.com/tbidne/monad-effects.git - name: effects-unix-compat + commit: 3ba8c43901087915bc9418c8ed095a7fad4f8ac1 + git: https://github.com/tbidne/effectful-effects.git + name: unix-compat-effectful pantry-tree: - sha256: 1672a1c422dc5669f40957ca87153bd47b30497e5de5bc90996122579de8bd5e - size: 366 - subdir: lib/effects-unix-compat + sha256: 8364c3c70dd5c7ab259d05a85ba2efd630f696ce27c9eed81c678325d6f011da + size: 528 + subdir: lib/unix-compat-effectful version: '0.1' original: - commit: 8021f9a0855e644d91b73e6b2bcf20406ebbebb8 - git: https://github.com/tbidne/monad-effects.git - subdir: lib/effects-unix-compat + commit: 3ba8c43901087915bc9418c8ed095a7fad4f8ac1 + git: https://github.com/tbidne/effectful-effects.git + subdir: lib/unix-compat-effectful - completed: commit: b3be9b3b904059671ef07dbcbb11b8c04d50ddde git: https://github.com/tbidne/relative-time.git diff --git a/test/functional/Functional/Examples/FileLogging.hs b/test/functional/Functional/Examples/FileLogging.hs index f7b44dcd..d71edcf9 100644 --- a/test/functional/Functional/Examples/FileLogging.hs +++ b/test/functional/Functional/Examples/FileLogging.hs @@ -2,6 +2,7 @@ module Functional.Examples.FileLogging (tests) where +import Effectful.FileSystem.PathReader.Static qualified as PR import Functional.Prelude import Functional.TestArgs (TestArgs) import Test.Shrun.Verifier qualified as V @@ -113,7 +114,7 @@ fileLogDeleteOnSuccess testArgs = ( \(resultsConsole, outFile) -> do V.verifyExpected resultsConsole expectedConsole - exists <- doesFileExist outFile + exists <- runFuncEff $ PR.doesFileExist outFile assertBool "File should not exist" (not exists) ) @@ -139,7 +140,7 @@ fileLogDeleteOnSuccessFail testArgs = testCase "Runs file-log-delete-on-success resultsConsole <- runExitFailure args V.verifyExpected resultsConsole expectedConsole - exists <- doesFileExist outFile + exists <- runFuncEff $ PR.doesFileExist outFile assertBool "File should exist" exists diff --git a/test/functional/Functional/Examples/Notify.hs b/test/functional/Functional/Examples/Notify.hs index 6042930d..8ba8b221 100644 --- a/test/functional/Functional/Examples/Notify.hs +++ b/test/functional/Functional/Examples/Notify.hs @@ -8,7 +8,7 @@ import Shrun.Configuration.Data.Notify.Timeout NotifyTimeoutSeconds ), ) -import Shrun.Notify.MonadNotify +import Shrun.Notify.Effect ( ShrunNote ( MkShrunNote, body, diff --git a/test/functional/Functional/Notify.hs b/test/functional/Functional/Notify.hs index 1d57d73c..d5063f49 100644 --- a/test/functional/Functional/Notify.hs +++ b/test/functional/Functional/Notify.hs @@ -6,7 +6,7 @@ import Functional.Prelude import Shrun.Configuration.Data.Notify.Timeout ( NotifyTimeout (NotifyTimeoutSeconds), ) -import Shrun.Notify.MonadNotify +import Shrun.Notify.Effect ( ShrunNote ( MkShrunNote, body, diff --git a/test/functional/Functional/Prelude.hs b/test/functional/Functional/Prelude.hs index 96d3d1e5..d592d45d 100644 --- a/test/functional/Functional/Prelude.hs +++ b/test/functional/Functional/Prelude.hs @@ -62,12 +62,18 @@ module Functional.Prelude scriptsHomeStr, notifySystemArg, readLogFile, + runFuncEff, ) where +import Data.IORef qualified as IORef import Data.String as X (IsString) import Data.Text qualified as T import Data.Typeable (typeRep) +import Effectful.FileSystem.FileReader.Static qualified as FR +import Effectful.FileSystem.PathReader.Static qualified as PR +import Effectful.FileSystem.PathWriter.Static qualified as PW +import Effectful.Terminal.Static qualified as Term import FileSystem.OsPath as X (combineFilePaths, unsafeDecode) import Functional.ReadStrategyTest ( ReadStrategyTestParams @@ -91,18 +97,17 @@ import Shrun.Configuration.Env.Types HasNotifyConfig (getNotifyConfig), HasTimeout (getTimeout), ) -import Shrun.Logging.MonadRegionLogger - ( MonadRegionLogger - ( Region, - displayRegions, - logGlobal, - logRegion, - withRegion +import Shrun.Logging.RegionLogger + ( RegionLogger + ( DisplayRegions, + LogGlobal, + LogRegion, + WithRegion ), ) -import Shrun.Notify.MonadNotify (MonadNotify (notify), ShrunNote) +import Shrun.Notify.DBus (DBus, runDBus) +import Shrun.Notify.Effect (Notify (Notify), ShrunNote) import Shrun.Prelude as X -import Shrun.ShellT (ShellT) import Test.Shrun.Verifier (ResultText (MkResultText)) import Test.Tasty as X ( TestTree, @@ -204,25 +209,77 @@ instance HasFileLogging FuncEnv where instance HasNotifyConfig FuncEnv where getNotifyConfig = getNotifyConfig . view #coreEnv -instance MonadRegionLogger (ShellT FuncEnv IO) where - type Region (ShellT FuncEnv IO) = () - - logGlobal txt = do - ls <- asks $ view #logs - liftIO $ modifyIORef' ls (txt :) - - logRegion _ _ = logGlobal - - withRegion _layout regionToShell = regionToShell () - - displayRegions = id - -instance MonadNotify (ShellT FuncEnv IO) where - notify note = do - notesRef <- asks (view #shrunNotes) +runRegionLogger :: + ( r ~ (), + HasCallStack, + IOE :> es, + IORefE :> es, + Reader FuncEnv :> es + ) => + Eff (RegionLogger r : es) a -> + Eff es a +runRegionLogger = interpret $ \env -> \case + LogGlobal txt -> writeLogs txt + LogRegion _ _ txt -> writeLogs txt + WithRegion _ regionToShell -> localSeqUnliftIO env $ \unlift -> + unlift (regionToShell ()) + DisplayRegions m -> localSeqUnliftIO env $ \unlift -> unlift m + where + writeLogs txt = do + ls <- asks @FuncEnv $ view #logs + modifyIORef' ls (txt :) + +runNotify :: + forall es a. + ( HasCallStack, + IORefE :> es, + Reader FuncEnv :> es + ) => + Eff (Notify : es) a -> + Eff es a +runNotify = interpret_ $ \case + Notify note -> do + notesRef <- asks @FuncEnv (view #shrunNotes) modifyIORef' notesRef (note :) pure Nothing +runFuncIO :: + Eff + [ DBus, + Environment, + Terminal, + PathWriter, + PathReader, + HandleWriter, + HandleReader, + FileWriter, + FileReader, + Time, + Optparse, + IORefE, + TypedProcess, + Concurrent, + IOE + ] + a -> + IO a +runFuncIO = + runEff + . runConcurrent + . runTypedProcess + . runIORef + . runOptparse + . runTime + . runFileReader + . runFileWriter + . runHandleReader + . runHandleWriter + . runPathReader + . runPathWriter + . runTerminal + . runEnvironment + . runDBus + -- | Runs the args and retrieves the logs. run :: List String -> IO (List ResultText) run = fmap fst . runMaybeException ExNothing @@ -257,10 +314,11 @@ runMaybeException :: List String -> IO (List ResultText, List ShrunNote) runMaybeException mException argList = do - ls <- newIORef [] - shrunNotes <- newIORef [] + ls <- IORef.newIORef [] + shrunNotes <- IORef.newIORef [] - let action = do + let action :: IO () + action = runFuncIO $ do withArgs argList $ Env.withEnv $ \env -> do let funcEnv = MkFuncEnv @@ -269,7 +327,10 @@ runMaybeException mException argList = do shrunNotes } - SR.runShellT SR.shrun funcEnv + runReader funcEnv + $ runRegionLogger + $ runNotify + $ SR.shrun @FuncEnv @() case mException of -- 1. Not expecting an exception @@ -310,7 +371,7 @@ runMaybeException mException argList = do IORef (List Text) -> IORef (List ShrunNote) -> IO (List ResultText, List ShrunNote) - readRefs ls ns = ((,) . fmap MkResultText <$> readIORef ls) <*> readIORef ns + readRefs ls ns = ((,) . fmap MkResultText <$> IORef.readIORef ls) <*> IORef.readIORef ns printLogsReThrow :: (Exception e) => e -> IORef (List Text) -> IO void printLogsReThrow ex ls = do @@ -320,13 +381,13 @@ runMaybeException mException argList = do throwM ex printLogs :: IORef (List Text) -> IO () - printLogs ls = do + printLogs ls = runFuncEff $ do logs <- readIORef ls - putStrLn "\n*** LOGS ***\n" + Term.putStrLn "\n*** LOGS ***\n" - for_ logs (putStrLn . unpack) - putStrLn "" + for_ logs (Term.putStrLn . unpack) + Term.putStrLn "" commandPrefix :: (IsString s) => s commandPrefix = "[Command]" @@ -393,11 +454,39 @@ notifySystemArg = "apple-script" notifySystemArg = "notify-send" #endif +-- | General effects we use for test definition / setup. This should all be +-- static since should be no mocking. +runFuncEff :: + (HasCallStack, MonadIO m) => + Eff + [ FR.FileReader, + FileWriter, + Term.Terminal, + PW.PathWriter, + PR.PathReader, + IORefE, + IOE + ] + a -> + m a +runFuncEff = + liftIO + . runEff + . runIORef + . PR.runPathReader + . PW.runPathWriter + . Term.runTerminal + . runFileWriter + . runFileReader + cfp :: FilePath -> FilePath -> FilePath cfp = combineFilePaths readLogFile :: OsPath -> IO (List ResultText) -readLogFile path = fmap MkResultText . T.lines <$> readFileUtf8ThrowM path +readLogFile path = + fmap MkResultText + . T.lines + <$> runFuncEff (readFileUtf8ThrowM path) appendScriptsHome :: (IsString a, Semigroup a) => a -> a appendScriptsHome p = scriptsHomeStr <> "/" <> p diff --git a/test/functional/Main.hs b/test/functional/Main.hs index 8345f266..869691ff 100644 --- a/test/functional/Main.hs +++ b/test/functional/Main.hs @@ -3,8 +3,9 @@ -- | Runs functional tests. module Main (main) where -import Effects.FileSystem.PathReader qualified as PR -import Effects.FileSystem.PathWriter qualified as PW +import Effectful.FileSystem.PathReader.Static qualified as PR +import Effectful.FileSystem.PathWriter.Static qualified as PW +import Effectful.Terminal.Static qualified as Term import Functional.Buffering qualified as Buffering import Functional.Examples qualified as Examples import Functional.Miscellaneous qualified as Miscellaneous @@ -22,13 +23,14 @@ import Functional.TestArgs import GHC.Conc.Sync (setUncaughtExceptionHandler) import System.Environment.Guard (guardOrElse') import System.Environment.Guard.Lifted (ExpectEnv (ExpectEnvSet)) +import System.IO qualified as IO import Test.Tasty qualified as Tasty import Test.Tasty.Options (OptionDescription (Option)) -- | Entry point for functional tests. main :: IO () main = do - setUncaughtExceptionHandler (putStrLn . displayException) + setUncaughtExceptionHandler (IO.putStrLn . displayException) Tasty.defaultMainWithIngredients ingredients $ Tasty.withResource setup teardown specs where ingredients = @@ -47,13 +49,13 @@ specs args = do setup :: IO TestArgs setup = do - rootTmpDir <- ( [osp|shrun|]) <$> PR.getTemporaryDirectory + rootTmpDir <- runFuncEff $ ( [osp|shrun|]) <$> PR.getTemporaryDirectory let workingTmpDir = rootTmpDir tmpName - cwd <- ( tmpName) <$> PR.getCurrentDirectory + cwd <- runFuncEff $ ( tmpName) <$> PR.getCurrentDirectory let lp = cwd [osp|config.toml|] - PW.createDirectoryIfMissing True workingTmpDir + runFuncEff $ PW.createDirectoryIfMissing True workingTmpDir pure $ MkTestArgs { rootDir = rootTmpDir, @@ -66,14 +68,15 @@ setup = do teardown :: TestArgs -> IO () teardown testArgs = guardOrElse' "NO_CLEANUP" ExpectEnvSet doNothing cleanup where - cleanup = do + cleanup = runFuncEff $ do let cwd = testArgs ^. #tmpDir -- see NOTE: [Test cleanup] PW.removeDirectoryRecursiveIfExists cwd doNothing = - putStrLn + runFuncEff + $ Term.putStrLn $ "*** Not cleaning up tmp dir: '" <> decodeLenient (testArgs ^. #tmpDir) <> "'" diff --git a/test/integration/Integration/Defaults.hs b/test/integration/Integration/Defaults.hs index d055af87..63a6d0a3 100644 --- a/test/integration/Integration/Defaults.hs +++ b/test/integration/Integration/Defaults.hs @@ -5,6 +5,7 @@ module Integration.Defaults (specs) where +import Data.IORef qualified as IORef import Integration.Prelude import Integration.Utils ( CompareField (MkCompareField), @@ -154,11 +155,11 @@ defaultEnv = testPropertyNamed desc "defaultEnv" $ withTests 1 $ property $ do - logsRef <- liftIO $ newIORef [] + logsRef <- liftIO $ IORef.newIORef [] makeConfigAndAssertEq ["cmd"] (`runNoConfigIO` logsRef) expected - logs <- liftIO $ readIORef logsRef + logs <- liftIO $ IORef.readIORef logsRef ["No default config found at: './config.toml'"] === logs where desc = "No arguments and empty config path should return default Env" @@ -169,10 +170,10 @@ usesDefaultConfigFile = testPropertyNamed desc "usesDefaultConfigFile" $ withTests 1 $ property $ do - logsRef <- liftIO $ newIORef [] + logsRef <- liftIO $ IORef.newIORef [] makeConfigAndAssertEq ["cmd1"] (`runConfigIO` logsRef) expected - logs <- liftIO $ readIORef logsRef + logs <- liftIO $ IORef.readIORef logsRef [] === logs where desc = "No arguments should use config from default file" @@ -234,12 +235,12 @@ cliOverridesConfigFile testArgs = testPropertyNamed desc "cliOverridesConfigFile $ property $ do logPath <- liftIO $ ( [osp|cli-log|]) . view #workingTmpDir <$> testArgs - logsRef <- liftIO $ newIORef [] + logsRef <- liftIO $ IORef.newIORef [] let logPathStr = unsafeDecode logPath makeConfigAndAssertEq (args logPathStr) (`runConfigIO` logsRef) (expected logPath) - logs <- liftIO $ readIORef logsRef + logs <- liftIO $ IORef.readIORef logsRef [] === logs where desc = "CLI args overrides config file" @@ -344,11 +345,11 @@ cliOverridesConfigFileCmdLog = testPropertyNamed desc "cliOverridesConfigFileCmd $ withTests 1 $ property $ do - logsRef <- liftIO $ newIORef [] + logsRef <- liftIO $ IORef.newIORef [] makeConfigAndAssertFieldEq args (`runConfigIO` logsRef) expected - logs <- liftIO $ readIORef logsRef + logs <- liftIO $ IORef.readIORef logsRef [] === logs where desc = "CLI overrides config file command-log fields even when CLI --console-log-command is not specified" @@ -371,11 +372,11 @@ cliOverridesConfigFileFileLog = testPropertyNamed desc "cliOverridesConfigFileFi $ withTests 1 $ property $ do - logsRef <- liftIO $ newIORef [] + logsRef <- liftIO $ IORef.newIORef [] makeConfigAndAssertFieldEq args (`runConfigIO` logsRef) expected - logs <- liftIO $ readIORef logsRef + logs <- liftIO $ IORef.readIORef logsRef [] === logs where desc = "CLI overrides config file file-log fields even when CLI --file-log is not specified" @@ -410,12 +411,12 @@ fileLogStripControlDefaultsAll = testPropertyNamed desc "fileLogStripControlDefa $ withTests 1 $ property $ do - logsRef <- liftIO $ newIORef [] + logsRef <- liftIO $ IORef.newIORef [] -- Test that no toml defaults to All makeConfigAndAssertFieldEq args1 (`runNoConfigIO` logsRef) expected - logs <- liftIO $ readIORef logsRef + logs <- liftIO $ IORef.readIORef logsRef ["No default config found at: './config.toml'"] === logs -- Test that with toml defaults to All @@ -445,10 +446,10 @@ ignoresDefaultConfigFile = testPropertyNamed desc "ignoresDefaultConfigFile" $ withTests 1 $ property $ do - logsRef <- liftIO $ newIORef [] + logsRef <- liftIO $ IORef.newIORef [] makeConfigAndAssertEq ["--no-config", "cmd"] (`runConfigIO` logsRef) expected - logs <- liftIO $ readIORef logsRef + logs <- liftIO $ IORef.readIORef logsRef [] === logs where desc = "--no-config should ignore config file" @@ -459,11 +460,11 @@ noXOverridesToml = testPropertyNamed desc "noXOverridesToml" $ withTests 1 $ property $ do - logsRef <- liftIO $ newIORef [] + logsRef <- liftIO $ IORef.newIORef [] makeConfigAndAssertEq args (`runConfigIO` logsRef) expected - logs <- liftIO $ readIORef logsRef + logs <- liftIO $ IORef.readIORef logsRef [] === logs where desc = "--no-x disables toml options" @@ -498,11 +499,11 @@ noXOverridesArgs = testPropertyNamed desc "noXOverridesArgs" $ withTests 1 $ property $ do - logsRef <- liftIO $ newIORef [] + logsRef <- liftIO $ IORef.newIORef [] makeConfigAndAssertEq args (`runConfigIO` logsRef) expected - logs <- liftIO $ readIORef logsRef + logs <- liftIO $ IORef.readIORef logsRef [] === logs where desc = "--no-x disables args" diff --git a/test/integration/Integration/Examples.hs b/test/integration/Integration/Examples.hs index 3b4ac552..d209fd12 100644 --- a/test/integration/Integration/Examples.hs +++ b/test/integration/Integration/Examples.hs @@ -95,10 +95,10 @@ examplesConfig = testPropertyNamed desc "examplesConfig" $ withTests 1 $ property $ do - logsRef <- liftIO $ newIORef [] + logsRef <- liftIO $ IORef.newIORef [] makeConfigAndAssertEq args (`runConfigIO` logsRef) expected - logs <- liftIO $ readIORef logsRef + logs <- liftIO $ IORef.readIORef logsRef [] === logs where desc = "examples/config.toml is valid" @@ -147,10 +147,10 @@ examplesDefault = testPropertyNamed desc "examplesDefault" $ withTests 1 $ property $ do - logsRef <- liftIO $ newIORef [] + logsRef <- liftIO $ IORef.newIORef [] makeConfigAndAssertEq args (`runConfigIO` logsRef) expected - logs <- liftIO $ readIORef logsRef + logs <- liftIO $ IORef.readIORef logsRef [] === logs where desc = "examples/default.toml is valid" diff --git a/test/integration/Integration/Failures.hs b/test/integration/Integration/Failures.hs index 3cd5913c..0308520d 100644 --- a/test/integration/Integration/Failures.hs +++ b/test/integration/Integration/Failures.hs @@ -5,6 +5,7 @@ module Integration.Failures (specs) where import Control.Exception (IOException) +import Data.IORef qualified as IORef import Data.List qualified as L import Data.Text qualified as T import Integration.Prelude @@ -37,7 +38,7 @@ specs testArgs = missingConfig :: TestTree missingConfig = testCase "Missing explicit config throws exception" $ do - logsRef <- newIORef [] + logsRef <- IORef.newIORef [] let args = ["-c", "bad-file.toml", "cmd"] result <- runCaptureError @IOException args logsRef @@ -48,7 +49,7 @@ missingConfig = testCase "Missing explicit config throws exception" $ do assertBool ("Exception: " ++ exMsg) (expectedStart `L.isPrefixOf` displayException ex) assertBool ("Exception: " ++ exMsg) (expectedEnd `L.isSuffixOf` displayException ex) - logs <- readIORef logsRef + logs <- IORef.readIORef logsRef logs @=? [] where expectedStart = "bad-file.toml" @@ -56,7 +57,7 @@ missingConfig = testCase "Missing explicit config throws exception" $ do duplicateKeys :: TestTree duplicateKeys = testCase "Duplicate keys throws exception" $ do - logsRef <- newIORef [] + logsRef <- IORef.newIORef [] let args = ["-c", getIntConfig "duplicate-keys", "cmd"] result <- runCaptureError args logsRef @@ -65,12 +66,12 @@ duplicateKeys = testCase "Duplicate keys throws exception" $ do "key1" @=? k Nothing -> assertFailure "Expected exception" - logs <- readIORef logsRef + logs <- IORef.readIORef logsRef logs @=? [] emptyKey :: TestTree emptyKey = testCase "Empty key throws exception" $ do - logsRef <- newIORef [] + logsRef <- IORef.newIORef [] let args = ["-c", getIntConfig "empty-key", "cmd"] result <- runCaptureError @TOMLError args logsRef @@ -78,14 +79,14 @@ emptyKey = testCase "Empty key throws exception" $ do Just err -> expectedErr @=? displayException err Nothing -> assertFailure "Expected exception" - logs <- readIORef logsRef + logs <- IORef.readIORef logsRef logs @=? [] where expectedErr = "Decode error at '.legend[0].key': Unexpected empty text" emptyValue :: TestTree emptyValue = testCase "Empty value throws exception" $ do - logsRef <- newIORef [] + logsRef <- IORef.newIORef [] let args = ["-c", getIntConfig "empty-value", "cmd"] result <- runCaptureError @TOMLError args logsRef @@ -93,14 +94,14 @@ emptyValue = testCase "Empty value throws exception" $ do Just err -> expectedErr @=? displayException err Nothing -> assertFailure "Exception exception" - logs <- readIORef logsRef + logs <- IORef.readIORef logsRef logs @=? [] where expectedErr = "Decode error at '.legend[0].val': Unexpected empty text" cyclicKeys :: TestTree cyclicKeys = testCase "Cyclic keys throws exception" $ do - logsRef <- newIORef [] + logsRef <- IORef.newIORef [] -- using config.toml, which has cyclic definition let args = ["a"] result <- runCaptureError args logsRef @@ -109,12 +110,12 @@ cyclicKeys = testCase "Cyclic keys throws exception" $ do Just (MkCyclicKeyError path) -> "a -> b -> c -> a" @=? path Nothing -> assertFailure "Exception exception" - logs <- readIORef logsRef + logs <- IORef.readIORef logsRef logs @=? [] emptyFileLog :: TestTree emptyFileLog = testCase "Empty file log throws exception" $ do - logsRef <- newIORef [] + logsRef <- IORef.newIORef [] let args = ["-c", getIntConfig "empty-file-log", "cmd"] result <- runCaptureError @TOMLError args logsRef @@ -122,7 +123,7 @@ emptyFileLog = testCase "Empty file log throws exception" $ do Just err -> expectedErr @=? displayException err Nothing -> assertFailure "Expected exception" - logs <- readIORef logsRef + logs <- IORef.readIORef logsRef logs @=? [] where expectedErr = "Decode error at '.file-log.path': Empty path given for --file-log" @@ -131,7 +132,7 @@ testReadStrategyFailure :: IO TestArgs -> TestTree testReadStrategyFailure testArgs = testCase desc $ do logPath <- liftIO $ ( [osp|read-strategy-failure|]) . view #workingTmpDir <$> testArgs let logsPathStr = unsafeDecode logPath - logsRef <- newIORef [] + logsRef <- IORef.newIORef [] result <- runCaptureError @ReadStrategyException (args logsPathStr) logsRef @@ -139,7 +140,7 @@ testReadStrategyFailure testArgs = testCase desc $ do Just err -> expectedErr @=? displayException err Nothing -> assertFailure "Expected exception" - logs <- readIORef logsRef + logs <- IORef.readIORef logsRef logs @=? [] where desc = "Read strategy block-line-buffer w/ multiple commands and file-logging throws error" @@ -169,7 +170,7 @@ osTests = osxNotifyConfigError :: TestTree osxNotifyConfigError = testCase "OSX with linux notify config throws exception" $ do - logsRef <- newIORef [] + logsRef <- IORef.newIORef [] -- Not getExampleConfigOS since we want to use the linux one w/ notify -- configuration let args = ["-c", getExampleConfig "config", "cmd"] @@ -181,7 +182,7 @@ osxNotifyConfigError = testCase "OSX with linux notify config throws exception" osxDBusError :: TestTree osxDBusError = testCase "OSX with dbus throws exception" $ do - logsRef <- newIORef [] + logsRef <- IORef.newIORef [] let args = ["--notify-system", "dbus" ,"cmd"] result <- runCaptureError @OsxNotifySystemMismatch args logsRef @@ -191,7 +192,7 @@ osxDBusError = testCase "OSX with dbus throws exception" $ do osxNotifySendError :: TestTree osxNotifySendError = testCase "OSX with notify-send throws exception" $ do - logsRef <- newIORef [] + logsRef <- IORef.newIORef [] let args = ["--notify-system", "notify-send" ,"cmd"] result <- runCaptureError @OsxNotifySystemMismatch args logsRef @@ -207,7 +208,7 @@ osTests = linuxNotifyConfigError :: TestTree linuxNotifyConfigError = testCase "Linux with osx notify config throws exception" $ do - logsRef <- newIORef [] + logsRef <- IORef.newIORef [] -- Not getExampleConfigOS since we want to use the linux one w/ notify -- configuration let args = ["-c", getExampleConfig "config_osx", "cmd"] @@ -219,7 +220,7 @@ linuxNotifyConfigError = testCase "Linux with osx notify config throws exception linuxAppleScriptError :: TestTree linuxAppleScriptError = testCase "Linux with apple-script throws exception" $ do - logsRef <- newIORef [] + logsRef <- IORef.newIORef [] let args = ["--notify-system", "apple-script" ,"cmd"] result <- runCaptureError @LinuxNotifySystemMismatch args logsRef @@ -228,11 +229,11 @@ linuxAppleScriptError = testCase "Linux with apple-script throws exception" $ do Nothing -> assertFailure "Expected exception" #endif -runCaptureError :: (Exception e) => [String] -> IORef [Text] -> IO (Maybe e) +runCaptureError :: forall e. (Exception e) => List String -> IORef (List Text) -> IO (Maybe e) runCaptureError args logsRef = - flip runConfigIO logsRef - $ withArgs args (withEnv pure $> Nothing) - `catch` \(ex :: e) -> pure (Just ex) + flip runConfigIO logsRef $ do + withArgs args (withEnv pure $> Nothing) + `catch` \(ex :: e) -> pure (Just ex) exContains :: (Exception e) => Text -> e -> Assertion exContains txt ex = assertBool (T.unpack desc) . T.isInfixOf txt $ exTxt diff --git a/test/integration/Integration/Miscellaneous.hs b/test/integration/Integration/Miscellaneous.hs index b0d078d5..4ee922a3 100644 --- a/test/integration/Integration/Miscellaneous.hs +++ b/test/integration/Integration/Miscellaneous.hs @@ -4,9 +4,11 @@ module Integration.Miscellaneous (specs) where +import Data.IORef qualified as IORef import Data.Sequence.NonEmpty qualified as NESeq import Data.String (IsString) import Data.Text qualified as T +import Effectful.FileSystem.PathReader.Static qualified as PR import Integration.Prelude import Integration.Utils ( makeConfigAndAssertFieldEq, @@ -54,22 +56,22 @@ logFileWarn testArgs = testPropertyNamed desc "logFileWarn" $ property $ do logPath <- liftIO $ ( [osp|large-file-warn|]) . view #workingTmpDir <$> testArgs - logsRef <- liftIO $ newIORef [] + logsRef <- liftIO $ IORef.newIORef [] let logsPathStr = unsafeDecode logPath contents = T.replicate 1_500 "test " - run = liftIO $ do - writeFileUtf8 logPath contents - startSize <- getFileSize logPath + run = do + runIntEff $ writeFileUtf8 logPath contents + startSize <- runIntEff $ PR.getFileSize logPath flip runConfigIO logsRef $ withArgs (args logsPathStr) (withEnv pure) - endSize <- getFileSize logPath + endSize <- runIntEff $ PR.getFileSize logPath pure (startSize, endSize) (startSize, endSize) <- run - exists <- liftIO $ doesFileExist logPath + exists <- runIntEff $ PR.doesFileExist logPath assert exists -- NOTE: [Log file unchanged] @@ -78,7 +80,7 @@ logFileWarn testArgs = testPropertyNamed desc "logFileWarn" -- shrun so the file should stay untouched. endSize === startSize - logs <- liftIO $ readIORef logsRef + logs <- liftIO $ IORef.readIORef logsRef [warning logsPathStr] === logs where desc = "Large log file should print warning" @@ -103,26 +105,26 @@ logFileDelete testArgs = testPropertyNamed desc "logFileDelete" $ property $ do logPath <- liftIO $ ( [osp|large-file-del|]) . view #workingTmpDir <$> testArgs - logsRef <- liftIO $ newIORef [] + logsRef <- liftIO $ IORef.newIORef [] let logPathStr = unsafeDecode logPath contents = T.replicate 1_500 "test " - run = liftIO $ do - writeFileUtf8 logPath contents + run = do + runIntEff $ writeFileUtf8 logPath contents flip runConfigIO logsRef $ withArgs (args logPathStr) (withEnv pure) - getFileSize logPath + runIntEff $ PR.getFileSize logPath endSize <- run - exists <- liftIO $ doesFileExist logPath + exists <- runIntEff $ PR.doesFileExist logPath assert exists -- file should have been deleted then recreated with a file size of 0. 0 === endSize - logs <- liftIO $ readIORef logsRef + logs <- liftIO $ IORef.readIORef logsRef [warning logPathStr] === logs where desc = "Large log file should be deleted" @@ -147,28 +149,28 @@ logFileNothing testArgs = testPropertyNamed desc "logFileNothing" $ property $ do logPath <- liftIO $ ( [osp|large-file-nothing|]) . view #workingTmpDir <$> testArgs - logsRef <- liftIO $ newIORef [] + logsRef <- liftIO $ IORef.newIORef [] let logsPathStr = unsafeDecode logPath contents = T.replicate 1_500 "test " - run = liftIO $ do - writeFileUtf8 logPath contents - startSize <- getFileSize logPath + run = do + runIntEff $ writeFileUtf8 logPath contents + startSize <- runIntEff $ PR.getFileSize logPath flip runConfigIO logsRef $ withArgs (args logsPathStr) (withEnv pure) - endSize <- getFileSize logPath + endSize <- runIntEff $ PR.getFileSize logPath pure (startSize, endSize) (startSize, endSize) <- run - exists <- liftIO $ doesFileExist logPath + exists <- runIntEff $ PR.doesFileExist logPath assert exists -- see NOTE: [Log file unchanged] endSize === startSize - logs <- liftIO $ readIORef logsRef + logs <- liftIO $ IORef.readIORef logsRef [] === logs where desc = "Large log file should print warning" @@ -185,10 +187,10 @@ usesRecursiveCmdExample = testPropertyNamed desc "usesRecursiveCmdExample" $ withTests 1 $ property $ do - logsRef <- liftIO $ newIORef [] + logsRef <- liftIO $ IORef.newIORef [] makeConfigAndAssertFieldEq args (`runConfigIO` logsRef) expected - logs <- liftIO $ readIORef logsRef + logs <- liftIO $ IORef.readIORef logsRef [] === logs where desc = "Uses recursive command from example" @@ -205,10 +207,10 @@ usesRecursiveCmd = testPropertyNamed desc "usesRecursiveCmd" $ withTests 1 $ property $ do - logsRef <- liftIO $ newIORef [] + logsRef <- liftIO $ IORef.newIORef [] makeConfigAndAssertFieldEq args (`runConfigIO` logsRef) expected - logs <- liftIO $ readIORef logsRef + logs <- liftIO $ IORef.readIORef logsRef [] === logs where desc = "Uses recursive commands" @@ -227,10 +229,10 @@ lineTruncDetect = testPropertyNamed desc "lineTruncDetect" $ withTests 1 $ property $ do - logsRef <- liftIO $ newIORef [] + logsRef <- liftIO $ IORef.newIORef [] makeConfigAndAssertFieldEq args (`runConfigIO` logsRef) expected - logs <- liftIO $ readIORef logsRef + logs <- liftIO $ IORef.readIORef logsRef logs === [] where desc = "lineTrunc reads 'detect' string from toml" @@ -246,10 +248,10 @@ testFileSizeModeNothing = testPropertyNamed desc "testFileSizeModeNothing" $ withTests 1 $ property $ do - logsRef <- liftIO $ newIORef [] + logsRef <- liftIO $ IORef.newIORef [] makeConfigAndAssertFieldEq args (`runNoConfigIO` logsRef) expected - logs <- liftIO $ readIORef logsRef + logs <- liftIO $ IORef.readIORef logsRef logs === [] where desc = "size-mode reads 'nothing'" @@ -262,10 +264,10 @@ testFileLogDeleteOnSuccess = testPropertyNamed desc "testFileLogDeleteOnSuccess" $ withTests 1 $ property $ do - logsRef <- liftIO $ newIORef [] + logsRef <- liftIO $ IORef.newIORef [] makeConfigAndAssertFieldEq args (`runNoConfigIO` logsRef) expected - logs <- liftIO $ readIORef logsRef + logs <- liftIO $ IORef.readIORef logsRef logs === [] where desc = "delete-on-success reads true" @@ -278,10 +280,10 @@ testReadBlockLineBufferReadStrategy = testPropertyNamed desc "testReadBlockLineB $ withTests 1 $ property $ do - logsRef <- liftIO $ newIORef [] + logsRef <- liftIO $ IORef.newIORef [] makeConfigAndAssertFieldEq args (`runNoConfigIO` logsRef) expected - logs <- liftIO $ readIORef logsRef + logs <- liftIO $ IORef.readIORef logsRef logs === [] where desc = "Read block-line-buffer read-strategy" @@ -289,15 +291,26 @@ testReadBlockLineBufferReadStrategy = testPropertyNamed desc "testReadBlockLineB expected = [#coreConfig % #commandLogging % #readStrategy ^=@ ReadBlockLineBuffer] -newtype TermIO a = MkTermIO (IO a) - deriving (Applicative, Functor, Monad, MonadThrow) via IO +-- newtype TermIO a = MkTermIO (IO a) +-- deriving (Applicative, Functor, Monad, MonadThrow) via IO -runTermIO :: (MonadIO m) => TermIO a -> m a -runTermIO (MkTermIO a) = liftIO a +-- runTermIO :: (MonadIO m) => TermIO a -> m a +-- runTermIO (MkTermIO a) = liftIO a --- For MonadTerminal instance (used to get window size; shouldn't be used +runTermIO :: (MonadIO m) => Eff [Terminal, IOE] a -> m a +runTermIO = + liftIO + . runEff + . runTerm + +-- For Terminal instance (used to get window size; shouldn't be used -- in default configs) -instance MonadTerminal TermIO +-- instance Terminal TermIO + +runTerm :: + Eff (Terminal : es) a -> + Eff es a +runTerm = interpret_ $ unimplWith "runTerminalConfig" testDefaultConfigs :: TestTree testDefaultConfigs = testPropertyNamed desc "testDefaultConfigs" diff --git a/test/integration/Integration/Prelude.hs b/test/integration/Integration/Prelude.hs index 3e374354..05eb24f9 100644 --- a/test/integration/Integration/Prelude.hs +++ b/test/integration/Integration/Prelude.hs @@ -9,9 +9,13 @@ module Integration.Prelude getIntConfig, getIntConfigOS, concatDirs, + runIntEff, ) where +import Effectful.FileSystem.PathReader.Static qualified as PR +import Effectful.FileSystem.PathWriter.Static qualified as PW +import Effectful.Terminal.Static qualified as Term import FileSystem.OsPath as X ( combineFilePaths, unsafeDecode, @@ -112,6 +116,27 @@ getIntConfig fileName = concatDirs :: [FilePath] -> FilePath concatDirs = foldr combineFilePaths [] +-- | General effects we use for test definition / setup. This should all be +-- static since should be no mocking. +runIntEff :: + (HasCallStack, MonadIO m) => + Eff + [ FileWriter, + Term.Terminal, + PW.PathWriter, + PR.PathReader, + IOE + ] + a -> + m a +runIntEff = + liftIO + . runEff + . PR.runPathReader + . PW.runPathWriter + . Term.runTerminal + . runFileWriter + osExt :: FilePath -> FilePath #if OSX osExt = (<> "_osx") diff --git a/test/integration/Integration/Utils.hs b/test/integration/Integration/Utils.hs index 82e52205..d1787478 100644 --- a/test/integration/Integration/Utils.hs +++ b/test/integration/Integration/Utils.hs @@ -4,9 +4,7 @@ module Integration.Utils ( -- * Running - ConfigIO (..), runConfigIO, - NoConfigIO (..), runNoConfigIO, -- * Assertions @@ -36,14 +34,16 @@ import DBus.Client ) import Data.Sequence.NonEmpty qualified as NESeq import Data.Text qualified as T -import Effects.FileSystem.PathReader - ( MonadPathReader - ( getHomeDirectory, - getXdgDirectory +import Effectful.FileSystem.PathReader.Dynamic + ( PathReader + ( DoesDirectoryExist, + DoesFileExist, + GetFileSize, + GetXdgDirectory ), ) -import Effects.System.Terminal - ( MonadTerminal (getChar, getTerminalSize), +import Effectful.Terminal.Dynamic + ( Terminal (GetTerminalSize, PutStrLn), Window (Window), ) import Integration.Prelude as X @@ -51,120 +51,144 @@ import Shrun.Configuration.Data.MergedConfig (MergedConfig, defaultMergedConfig) import Shrun.Configuration.Data.Notify.System (NotifySystemMerged) import Shrun.Configuration.Data.Notify.System qualified as Notify.System import Shrun.Configuration.Env qualified as Env -import Shrun.Notify.DBus (MonadDBus (connectSession, notify)) +import Shrun.Notify.DBus (DBus (ConnectSession, Notify)) --- IO that has a default config file specified at test/unit/Unit/toml/config.toml -newtype ConfigIO a = MkConfigIO (ReaderT (IORef [Text]) IO a) - deriving - ( Applicative, - Functor, - Monad, - MonadCatch, - MonadEnv, - MonadFileReader, - MonadFileWriter, - MonadHandleWriter, - MonadIO, - MonadMask, - MonadOptparse, - MonadPathWriter, - MonadIORef, - MonadReader (IORef [Text]), - MonadSTM, - MonadThrow - ) - via (ReaderT (IORef [Text])) IO - -runConfigIO :: ConfigIO a -> IORef [Text] -> IO a -runConfigIO (MkConfigIO rdr) = runReaderT rdr - --- HACK: Listing all the MonadPathReader methods is tedious and unnecessary, --- so rather than list all of them like @foo = error "todo"@, we simply --- disable the warning with -Wno-missing-methods - -instance MonadPathReader ConfigIO where - getFileSize = liftIO . getFileSize - doesFileExist = liftIO . doesFileExist - doesDirectoryExist = liftIO . doesDirectoryExist +{- ORMOLU_DISABLE -} +-- IO that has a default config file specified at test/unit/Unit/toml/config.toml +runPathReaderConfig :: (IOE :> es) => Eff (PathReader : es) a -> Eff es a +runPathReaderConfig = reinterpret runPathReader $ \_ -> \case + GetFileSize p -> getFileSize p + DoesFileExist p -> doesFileExist p + DoesDirectoryExist p -> doesDirectoryExist p #if OSX - getXdgDirectory _ _ = - pure (unsafeEncode $ concatDirs ["test", "integration", "toml", "osx"]) + GetXdgDirectory _ _ -> pure [ospPathSep|test/integration/toml/osx|] #else - getXdgDirectory _ _ = - pure (unsafeEncode $ concatDirs ["test", "integration", "toml"]) + GetXdgDirectory _ _ -> pure [ospPathSep|test/integration/toml|] #endif + _ -> unimplWith "runPathReaderConfig" -instance MonadTerminal ConfigIO where - putStr = error "putStr: unimplemented" - - -- capture logs - putStrLn t = ask >>= (`modifyIORef'` (T.pack t :)) - - getChar = error "getChar: unimplemented" +{- ORMOLU_ENABLE -} - -- hardcoded so we can test 'detect' - getTerminalSize = pure (Window 23 87) - -instance MonadDBus ConfigIO where - connectSession = +runTerminalConfig :: + ( IORefE :> es, + Reader (IORef [Text]) :> es + ) => + Eff (Terminal : es) a -> + Eff es a +runTerminalConfig = interpret_ $ \case + PutStrLn t -> do + logsRef <- ask + modifyIORef' logsRef (T.pack t :) + GetTerminalSize -> pure (Window 23 87) + _ -> unimplWith "runTerminalConfig" + +runDBusConfig :: Eff (DBus : es) a -> Eff es a +runDBusConfig = interpret_ $ \case + ConnectSession -> pure $ Client - { clientSocket = error "todo", - clientPendingCalls = error "todo", - clientSignalHandlers = error "todo", - clientObjects = error "todo", - clientThreadID = error "todo", - clientInterfaces = error "todo" + { clientSocket = unimpl, + clientPendingCalls = unimpl, + clientSignalHandlers = unimpl, + clientObjects = unimpl, + clientThreadID = unimpl, + clientInterfaces = unimpl } - notify = error "notify: unimplemented" - --- IO with no default config file -newtype NoConfigIO a = MkNoConfigIO (ReaderT (IORef [Text]) IO a) - deriving - ( Applicative, - MonadPathWriter, - Functor, - Monad, - MonadCatch, - MonadEnv, - MonadFileReader, - MonadFileWriter, - MonadHandleWriter, - MonadIO, - MonadMask, - MonadOptparse, - MonadSTM, - MonadThrow - ) - via (ReaderT (IORef [Text])) IO - deriving (MonadDBus) via ConfigIO - -runNoConfigIO :: NoConfigIO a -> IORef [Text] -> IO a -runNoConfigIO (MkNoConfigIO rdr) = runReaderT rdr - -instance MonadPathReader NoConfigIO where - getXdgDirectory _ _ = pure [osp|./|] - getHomeDirectory = error "getHomeDirectory: unimplemented" - doesFileExist = liftIO . doesFileExist - -deriving via ConfigIO instance MonadTerminal NoConfigIO + Notify _ _ -> unimpl + +runConfigIO :: + (MonadIO m) => + Eff + [ DBus, + FileReader, + FileWriter, + HandleWriter, + Optparse, + PathReader, + PathWriter, + Terminal, + Environment, + IORefE, + Reader (IORef (List Text)), + Concurrent, + IOE + ] + a -> + IORef [Text] -> + m a +runConfigIO m ref = + liftIO + . runEff + . runConcurrent + . runReader ref + . runIORef + . runEnvironment + . runTerminalConfig + . runPathWriter + . runPathReaderConfig + . runOptparse + . runHandleWriter + . runFileWriter + . runFileReader + . runDBusConfig + $ m + +runNoConfigIO :: + Eff + [ DBus, + FileReader, + FileWriter, + HandleWriter, + Optparse, + PathReader, + PathWriter, + Terminal, + Environment, + IORefE, + Reader (IORef (List Text)), + Concurrent, + IOE + ] + a -> + IORef [Text] -> + IO a +runNoConfigIO m ref = + runEff + . runConcurrent + . runReader ref + . runIORef + . runEnvironment + . runTerminalConfig + . runPathWriter + . runPathReaderNoConfig + . runOptparse + . runHandleWriter + . runFileWriter + . runFileReader + . runDBusConfig + $ m + +runPathReaderNoConfig :: (IOE :> es) => Eff (PathReader : es) a -> Eff es a +runPathReaderNoConfig = reinterpret runPathReader $ \_ -> \case + DoesFileExist p -> doesFileExist p + GetXdgDirectory _ _ -> pure [osp|./|] + _ -> unimplWith "runPathReaderNoConfig" -- | Makes a 'MergedConfig' for the given monad and compares the result with -- the expectation. makeConfigAndAssertEq :: - forall m. - ( MonadEnv m, - MonadFileReader m, - MonadMask m, - MonadOptparse m, - MonadPathReader m, - MonadTerminal m + forall es. + ( Environment :> es, + FileReader :> es, + Optparse :> es, + PathReader :> es, + Terminal :> es ) => -- | List of CLI arguments. List String -> -- | Natural transformation from m to IO. - (forall x. m x -> IO x) -> + (forall x. Eff es x -> IO x) -> -- | Expectation. MergedConfig -> PropertyT IO () @@ -198,18 +222,17 @@ infix 1 ^?=@ -- | Like 'makeConfigAndAssertEq' except we only compare select fields. makeConfigAndAssertFieldEq :: - forall m. - ( MonadEnv m, - MonadFileReader m, - MonadMask m, - MonadOptparse m, - MonadPathReader m, - MonadTerminal m + forall es. + ( Environment :> es, + FileReader :> es, + Optparse :> es, + PathReader :> es, + Terminal :> es ) => -- | List of CLI arguments. List String -> -- | Natural transformation from m to IO. - (forall x. m x -> IO x) -> + (forall x. Eff es x -> IO x) -> -- | List of expectations. List CompareField -> PropertyT IO () @@ -221,18 +244,17 @@ makeConfigAndAssertFieldEq args toIO comparisons = do MkCompareFieldMaybe l expected -> expected === result ^? l makeMergedConfig :: - forall m. - ( MonadEnv m, - MonadFileReader m, - MonadMask m, - MonadOptparse m, - MonadPathReader m, - MonadTerminal m + forall es. + ( Environment :> es, + FileReader :> es, + Optparse :> es, + PathReader :> es, + Terminal :> es ) => -- | List of CLI arguments. List String -> -- | Natural transformation from m to IO. - (forall x. m x -> IO x) -> + (forall x. Eff es x -> IO x) -> PropertyT IO MergedConfig makeMergedConfig args toIO = do result <- liftIO $ toIO $ withArgs args Env.getMergedConfig diff --git a/test/integration/Main.hs b/test/integration/Main.hs index 46daff48..370d076c 100644 --- a/test/integration/Main.hs +++ b/test/integration/Main.hs @@ -3,8 +3,8 @@ -- | Runs integration tests. module Main (main) where -import Effects.FileSystem.PathReader qualified as PR -import Effects.FileSystem.PathWriter qualified as PW +import Effectful.FileSystem.PathReader.Static qualified as PR +import Effectful.FileSystem.PathWriter.Static qualified as PW import Integration.Defaults qualified as Defaults import Integration.Examples qualified as Examples import Integration.Failures qualified as Failures @@ -28,25 +28,43 @@ main = do setup :: IO TestArgs setup = do - rootTmpDir <- ( [osp|shrun|]) <$> PR.getTemporaryDirectory + rootTmpDir <- runEff' $ ( [osp|shrun|]) <$> PR.getTemporaryDirectory let workingTmpDir = rootTmpDir [osp|test/integration|] - PW.createDirectoryIfMissing True workingTmpDir + runEff' $ PW.createDirectoryIfMissing True workingTmpDir pure $ MkTestArgs rootTmpDir workingTmpDir teardown :: TestArgs -> IO () teardown testArgs = guardOrElse' "NO_CLEANUP" ExpectEnvSet doNothing cleanup where doNothing = - putStrLn + runEff' + $ putStrLn $ "*** Not cleaning up tmp dir: '" <> decodeLenient (testArgs ^. #rootTmpDir) <> "'" - cleanup = do + cleanup = runEff' $ do let cwd = testArgs ^. #workingTmpDir -- NOTE: [Test cleanup] -- -- Don't delete rootTmp because other tests may be using it. PW.removeDirectoryRecursiveIfExists cwd + +runEff' :: + Eff + [ FileWriter, + Terminal, + PW.PathWriter, + PR.PathReader, + IOE + ] + a -> + IO a +runEff' = + runEff + . PR.runPathReader + . PW.runPathWriter + . runTerminal + . runFileWriter diff --git a/test/notify/Main.hs b/test/notify/Main.hs index ec1d2855..02c5b73a 100644 --- a/test/notify/Main.hs +++ b/test/notify/Main.hs @@ -5,9 +5,17 @@ -- | Runs functional tests. module Main (main) where +import Data.IORef qualified as IORef import Data.Text qualified as T import GHC.Conc.Sync (setUncaughtExceptionHandler) -import Shrun (shrun) +import Shrun qualified as SR +import Shrun.Configuration.Data.Notify.System + ( NotifySystemP + ( AppleScript, + DBus, + NotifySend + ), + ) import Shrun.Configuration.Env (withEnv) import Shrun.Configuration.Env.Types ( Env, @@ -21,21 +29,24 @@ import Shrun.Configuration.Env.Types HasNotifyConfig (getNotifyConfig), HasTimeout (getTimeout), ) -import Shrun.Logging.MonadRegionLogger - ( MonadRegionLogger - ( Region, - displayRegions, - logGlobal, - logRegion, - withRegion +import Shrun.Logging.RegionLogger + ( RegionLogger + ( DisplayRegions, + LogGlobal, + LogRegion, + WithRegion ), ) import Shrun.Logging.Types (LogRegion) -import Shrun.Notify.MonadNotify (MonadNotify (notify)) +import Shrun.Notify.AppleScript qualified as AppleScript +import Shrun.Notify.DBus qualified as DBus +import Shrun.Notify.Effect (Notify (Notify)) +import Shrun.Notify.NotifySend qualified as NotifySend import Shrun.Prelude -import Shrun.ShellT (ShellT, runShellT) +import System.Environment qualified as SysEnv import System.Environment.Guard (guardOrElse') import System.Environment.Guard.Lifted (ExpectEnv (ExpectEnvSet)) +import System.IO qualified as IO import Test.Tasty (TestTree, defaultMain, testGroup) import Test.Tasty.HUnit (assertFailure, testCase) @@ -44,10 +55,10 @@ main :: IO () main = guardOrElse' "NOTIFY_TESTS" ExpectEnvSet runTests dontRun where runTests = do - setUncaughtExceptionHandler (putStrLn . displayException) + setUncaughtExceptionHandler (IO.putStrLn . displayException) defaultMain tests - dontRun = putStrLn "*** Notify tests disabled. Enable with NOTIFY_TESTS=1 ***" + dontRun = IO.putStrLn "*** Notify tests disabled. Enable with NOTIFY_TESTS=1 ***" tests :: TestTree tests = do @@ -72,7 +83,7 @@ osTests = -- in legend file commands. notifySendHandlesLegendQuotes :: TestTree notifySendHandlesLegendQuotes = testCase "notify-send handles legend quotes" $ do - runShrun args + runNotifyIO args where args = [ "--common-log-key-hide", @@ -143,44 +154,61 @@ instance HasNotifyConfig NotifyEnv where instance HasTimeout NotifyEnv where getTimeout = getTimeout . (.unNotifyEnv) -liftNotify :: ShellT (Env ()) IO a -> ShellT NotifyEnv IO a -liftNotify m = do - MkNotifyEnv env _ _ <- ask - liftIO $ runShellT m env - -instance MonadNotify (ShellT NotifyEnv IO) where - notify = liftNotify . notify - -instance MonadRegionLogger (ShellT NotifyEnv IO) where - type Region (ShellT NotifyEnv IO) = () - - logGlobal t = asks (.logsRef) >>= \ref -> modifyIORef' ref (t :) - logRegion _ _ t = asks (.logsRef) >>= \ref -> modifyIORef' ref (t :) - withRegion _ onRegion = onRegion () - displayRegions m = m +runNotify :: + ( DBus.DBus :> es, + Reader NotifyEnv :> es, + TypedProcess :> es + ) => + Eff (Notify : es) a -> + Eff es a +runNotify = interpret_ $ \case + Notify note -> do + asks @NotifyEnv (preview (#config % #notify %? #system) . (.unNotifyEnv)) >>= \case + Nothing -> pure Nothing + Just nenv -> sendNote nenv + where + sendNote (DBus client) = DBus.notifyDBus client note + sendNote NotifySend = NotifySend.notifyNotifySend note + sendNote AppleScript = AppleScript.notifyAppleScript note + +runRegionLogger :: + ( r ~ (), + HasCallStack, + IOE :> es, + IORefE :> es, + Reader NotifyEnv :> es + ) => + Eff (RegionLogger r : es) a -> + Eff es a +runRegionLogger = interpret $ \env -> \case + LogGlobal txt -> writeLogs txt + LogRegion _ _ txt -> writeLogs txt + WithRegion _ regionToShell -> localSeqUnliftIO env $ \unlift -> + unlift (regionToShell ()) + DisplayRegions m -> localSeqUnliftIO env $ \unlift -> unlift m + where + writeLogs txt = do + ls <- asks @NotifyEnv $ (.logsRef) + modifyIORef' ls (txt :) runShrunNoConfig :: List String -> IO () -runShrunNoConfig = runShrun . ("--no-config" :) - -runShrun :: List String -> IO () -runShrun args = do - consoleQueue <- newTBQueueA 1 - logsRef <- newIORef [] - eSomeEx <- - trySync - $ withArgs - args - ( withEnv - ( \env -> - runShellT shrun - $ MkNotifyEnv env consoleQueue logsRef - ) - ) +runShrunNoConfig = runNotifyIO . ("--no-config" :) + +runNotifyIO :: List String -> IO () +runNotifyIO args = do + logsRef <- IORef.newIORef [] + eSomeEx <- trySync $ SysEnv.withArgs args $ runShrun $ withEnv $ \env -> do + consoleQueue <- newTBQueueA 1 + let notifyEnv = MkNotifyEnv env consoleQueue logsRef + runReader notifyEnv + $ runRegionLogger + $ runNotify + $ SR.shrun @NotifyEnv @() case eSomeEx of Right () -> pure () Left ex -> do - logs <- readIORef logsRef + logs <- IORef.readIORef logsRef let formatted = T.intercalate "\n" logs err = @@ -193,3 +221,19 @@ runShrun args = do ] assertFailure err + where + runShrun = + runEff + . runConcurrent + . runTypedProcess + . runIORef + . runFileReader + . runFileWriter + . runHandleReader + . runHandleWriter + . runOptparse + . runPathReader + . runPathWriter + . runTerminal + . runTime + . DBus.runDBus diff --git a/test/unit/Unit/Generators.hs b/test/unit/Unit/Generators.hs index 6de315d2..55668963 100644 --- a/test/unit/Unit/Generators.hs +++ b/test/unit/Unit/Generators.hs @@ -10,7 +10,7 @@ module Unit.Generators ) where -import Effects.Time (TimeSpec (MkTimeSpec)) +import Effectful.Time.Dynamic (TimeSpec (MkTimeSpec)) import Hedgehog.Gen qualified as Gen import Hedgehog.Range qualified as Range import Shrun.Data.Text (UnlinedText) diff --git a/test/unit/Unit/Shrun/Configuration/Args/Parsing.hs b/test/unit/Unit/Shrun/Configuration/Args/Parsing.hs index e64d967e..74f68d12 100644 --- a/test/unit/Unit/Shrun/Configuration/Args/Parsing.hs +++ b/test/unit/Unit/Shrun/Configuration/Args/Parsing.hs @@ -98,7 +98,11 @@ testDefaultOption = testPropertyNamed desc "testDefaultOption" $ withTests 1 $ property $ do - expected <- liftIO $ readFileUtf8ThrowM [osp|examples/default.toml|] + expected <- + liftIO + $ runEff + $ runFileReader + $ readFileUtf8ThrowM [osp|examples/default.toml|] let result = U.execParserUnit ["--default-config"] diff --git a/test/unit/Unit/Shrun/Logging/Formatting.hs b/test/unit/Unit/Shrun/Logging/Formatting.hs index dd802602..deba5b01 100644 --- a/test/unit/Unit/Shrun/Logging/Formatting.hs +++ b/test/unit/Unit/Shrun/Logging/Formatting.hs @@ -1,15 +1,14 @@ -- | Tests for Shrun.Logging.Formatting. module Unit.Shrun.Logging.Formatting (tests) where -import Data.Functor.Identity (Identity (Identity)) import Data.List qualified as L import Data.String (IsString) import Data.Text qualified as T import Data.Time (midday) import Data.Time.LocalTime (utc) -import Effects.Time +import Effectful.Time.Dynamic ( LocalTime (LocalTime), - MonadTime (getMonotonicTime, getSystemZonedTime), + Time (GetMonotonicTime, GetSystemZonedTime), ZonedTime (ZonedTime), ) import Shrun.Configuration.Data.CommonLogging.KeyHideSwitch @@ -512,10 +511,10 @@ testFormatsFLLineTrunc = testCase desc $ do runFormatFileLog :: KeyHideSwitch -> FileLoggingEnv -> Log -> Text runFormatFileLog keyHide env log = view #unFileLog - $ Formatting.formatFileLog @MockTime keyHide env log - ^. #runMockTime + $ runMock + $ Formatting.formatFileLog keyHide env log --- The mock time our 'MonadTime' returns. Needs to be kept in sync with +-- The mock time our 'Time' returns. Needs to be kept in sync with -- getSystemZonedTime below. sysTime :: (IsString a) => a sysTime = "2020-05-31 12:00:00" @@ -524,22 +523,13 @@ sysTime = "2020-05-31 12:00:00" sysTimeNE :: Text sysTimeNE = "[" <> sysTime <> "]" -newtype MockEnv = MkMockEnv () +runMock :: Eff '[Time] a -> a +runMock = runPureEff . runTimeMock --- Monad with mock implementation for 'MonadTime'. -newtype MockTime a = MkMockTime - { runMockTime :: a - } - deriving stock (Eq, Generic, Show) - deriving (Applicative, Functor, Monad) via Identity - -instance MonadTime MockTime where - getSystemZonedTime = pure $ ZonedTime (LocalTime (toEnum 59_000) midday) utc - getMonotonicTime = pure 0 - -instance MonadReader MockEnv MockTime where - ask = pure $ MkMockEnv () - local _ = id +runTimeMock :: Eff (Time : es) a -> Eff es a +runTimeMock = interpret_ $ \case + GetSystemZonedTime -> pure $ ZonedTime (LocalTime (toEnum 59_000) midday) utc + GetMonotonicTime -> pure 0 baseFileLoggingEnv :: FileLoggingEnv baseFileLoggingEnv =