From f135f6a139b13c43bf1a4c3d3eaf317f5cf0de7b Mon Sep 17 00:00:00 2001 From: Vladislav Sabanov Date: Mon, 26 May 2025 10:00:15 -0300 Subject: [PATCH 1/2] Land concurrent actions on ki --- lineman.cabal | 3 ++- src/App.hs | 7 ++++--- src/Lineman.hs | 44 ++++++++++++++++++++++++-------------------- src/Types.hs | 39 ++++++++++++++++++++++++++++++++++++++- 4 files changed, 68 insertions(+), 25 deletions(-) diff --git a/lineman.cabal b/lineman.cabal index f49303c..8609b4c 100644 --- a/lineman.cabal +++ b/lineman.cabal @@ -66,7 +66,7 @@ library , extra , filepath , katip - , lifted-async + , ki , monad-control , mtl , path @@ -74,6 +74,7 @@ library , pretty-simple , process , safe-exceptions + , stm , text , transformers-base diff --git a/src/App.hs b/src/App.hs index 6ed622d..67f3324 100644 --- a/src/App.hs +++ b/src/App.hs @@ -5,9 +5,9 @@ module App ( import Cook (safeHead) import Lineman (launchAction) import Log (mkLogEnv) -import Types (App (unApp), Config (..), Env (..)) +import Types (App (unApp), Config (..), Env (..), forConcurrentlyKi) -import Control.Concurrent.Async.Lifted (forConcurrently) +-- import Control.Concurrent.Async.Lifted (forConcurrently) import Control.Exception.Safe (throwIO, tryAny) import Control.Monad (forM, when) import Control.Monad.Reader (ReaderT (..)) @@ -32,7 +32,7 @@ appLineman = do { envLogEnv = logEnv , envActionMode = if cAsync config - then forConcurrently + then forConcurrentlyKi else forM , envLogContext = mempty , envLogNamespace = mempty @@ -52,3 +52,4 @@ getConfig path = do pPrintString "Config parsing failed" throwIO err Right decoded -> pure decoded + diff --git a/src/Lineman.hs b/src/Lineman.hs index b9d7d1e..7be1893 100644 --- a/src/Lineman.hs +++ b/src/Lineman.hs @@ -1,24 +1,27 @@ +{-# LANGUAGE NumericUnderscores #-} +{-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE TypeApplications #-} module Lineman ( launchAction, -) where - -import Cook (prepareConditions) -import Log (logDebug, logError, logInfo) -import Types (App, Env (..)) +) +where +-- import Control.Concurrent (threadDelay) import Control.Exception.Safe (try) import Control.Monad (forM_) import qualified Control.Monad.Extra as E import Control.Monad.IO.Class (liftIO) import Control.Monad.Reader (asks) +import Cook (prepareConditions) import qualified Data.Text as T import GHC.IO.Exception (ExitCode (..)) -import Path.IO (doesDirExist, doesFileExist, listDir, listDirRecur, withCurrentDir) -import Path.Posix (Abs, Dir, File, Path, PathException, Rel, fileExtension, ()) -import System.Process (proc, readCreateProcessWithExitCode) +import Log (logDebug, logError, logInfo) +import Path.IO (doesDirExist, doesFileExist, listDir, listDirRecur) +import Path.Posix (Abs, Dir, File, Path, PathException, Rel, fileExtension, toFilePath, ()) +import System.Process (CreateProcess (..), proc, readCreateProcessWithExitCode) import System.Process.Extra (showCommandForUser) +import Types (App, Env (..)) import Prelude hiding (log) launchAction :: App () @@ -31,14 +34,14 @@ launchAction = do dirsForLaunch <- case (mTarget, mFiles) of (Just t, Just fs) -> getDirsForCommand t fs dirs exts _ -> pure [] - logDebug $ T.pack $ show dirsForLaunch + logDebug $ "Directories for running action: " <> T.pack (show dirsForLaunch) forAction <- asks envActionMode codes <- seq dirsForLaunch $ forAction dirsForLaunch $ \d -> do let act = showCommandForUser command args let dir = T.pack (show d) logInfo $ "Action \'" <> T.pack act <> "\' is running in " <> dir - withCurrentDir d $ action command args + action command args d if all (== ExitSuccess) codes then logInfo "All actions successfuly finished!" else logError "Some action(s) failed" @@ -48,20 +51,21 @@ getDirsForCommand target files dirs exts = do (targets, _) <- listDirRecur target seq targets $ do res <- findDirsDyFiles (target : targets) files dirs exts - logDebug $ "findDirsDyFiles: " <> T.pack (show res) + logDebug $ "Found directories: " <> T.pack (show res) pure res -action :: FilePath -> [String] -> App ExitCode -action commandName args = do - (exitCode, stdout, stderr) <- +action :: FilePath -> [String] -> Path Abs Dir -> App ExitCode +action commandName args path = do + -- liftIO $ threadDelay 500_000 -- 0.5 seconds + (exitCode, stdout, stderr) <- liftIO $ - readCreateProcessWithExitCode (proc commandName args) "" + readCreateProcessWithExitCode (proc commandName args){cwd = Just $ toFilePath path} "" case stderr of "" -> pure () - err -> logError $ "stderr: \n" <> T.strip (T.pack err) + err -> logError $ "In " <> T.pack (show path) <> " occurred stderr: \n" <> T.strip (T.pack err) case stdout of "" -> pure () - out -> logDebug $ "stdout: \n" <> T.pack out + out -> logDebug $ "In " <> T.pack (show path) <> " occurred stdout: \n" <> T.pack out logDebug $ T.pack (show exitCode) pure exitCode @@ -81,9 +85,9 @@ findDirsDyFiles d [] [] [] = pure d findDirsDyFiles (d : ds) files dirs exts = do dFiles <- snd <$> listDir d existFiles <- E.allM (\f -> doesFileExist $ d f) files - logDebug $ T.pack (show d) - logDebug $ T.pack (show files) - logDebug $ T.pack (show existFiles) + logDebug $ "In directory: " <> T.pack (show d) + logDebug $ "file(s) " <> T.pack (show files) + logDebug $ "exist? " <> T.pack (show existFiles) existDirs <- E.allM (\f -> doesDirExist $ d f) dirs existExts <- isExtsInFiles exts dFiles if existFiles && existDirs && existExts diff --git a/src/Types.hs b/src/Types.hs index 74d461c..71158da 100644 --- a/src/Types.hs +++ b/src/Types.hs @@ -10,6 +10,8 @@ {-# LANGUAGE MultiParamTypeClasses #-} {-# LANGUAGE StandaloneDeriving #-} {-# LANGUAGE StrictData #-} +{-# LANGUAGE BlockArguments #-} +{-# LANGUAGE TypeOperators #-} {-# LANGUAGE UndecidableInstances #-} {-# OPTIONS_GHC -fno-warn-orphans #-} @@ -19,6 +21,7 @@ module Types ( Conditions (..), Config (..), ActionMode, + forConcurrentlyKi, ) where import Control.Exception.Safe (MonadCatch, MonadMask, MonadThrow) @@ -30,13 +33,17 @@ import Control.Monad.Reader ( asks, local, ) -import Control.Monad.Trans.Control (MonadBaseControl) +import Control.Monad.Trans.Control (MonadBaseControl, StM, control) +import Control.Monad.Base (MonadBase (liftBase)) import Data.Set (Set) import Dhall (FromDhall (..)) import GHC.Generics (Generic) import GHC.IO.Exception (ExitCode (..)) import Katip (Katip (..), KatipContext (..), LogContexts, LogEnv (..), Namespace, Severity, Verbosity) import Path.Posix (Abs, Dir, Path) +import Ki +import Control.Concurrent.STM (atomically) + newtype App a = MkApp { unApp :: ReaderT Env IO a @@ -56,15 +63,21 @@ newtype App a = MkApp ) instance Katip App where + getLogEnv :: App LogEnv getLogEnv = asks envLogEnv + localLogEnv :: (LogEnv -> LogEnv) -> App a -> App a localLogEnv f (MkApp m) = MkApp (local (\s -> s{envLogEnv = f (envLogEnv s)}) m) instance KatipContext App where + getKatipContext :: App LogContexts getKatipContext = asks envLogContext + localKatipContext :: (LogContexts -> LogContexts) -> App a -> App a localKatipContext f (MkApp m) = MkApp (local (\s -> s{envLogContext = f (envLogContext s)}) m) + getKatipNamespace :: App Namespace getKatipNamespace = asks envLogNamespace + localKatipNamespace :: (Namespace -> Namespace) -> App a -> App a localKatipNamespace f (MkApp m) = MkApp (local (\s -> s{envLogNamespace = f (envLogNamespace s)}) m) @@ -101,3 +114,27 @@ data Conditions = Conditions } deriving stock (Eq, Show, Generic, Ord) deriving anyclass (FromDhall) + +forConcurrentlyKi :: + (MonadBaseControl IO m, StM m (Ki.Thread b) ~ Ki.Thread b, StM m b ~ b, MonadIO m) => + [a] -> + (a -> m b) -> + m [b] +forConcurrentlyKi ns f = control $ \unlift -> scopedM \scope -> unlift $ do + threads <- mapM (forkM scope . f) ns + mapM (liftBase . atomically . Ki.await) threads + +forkM :: + (MonadBaseControl IO m, StM m (Ki.Thread a) ~ Ki.Thread a, StM m a ~ a) => + Ki.Scope -> + m a -> + m (Ki.Thread a) +forkM scope action = + control \unlift -> Ki.fork scope (unlift action) + +scopedM :: + (MonadBaseControl IO m, StM m a ~ a) => + (Ki.Scope -> m a) -> + m a +scopedM action = + control \unlift -> Ki.scoped \scope -> unlift (action scope) \ No newline at end of file From 5e5c1a8b4ab0704c3b7dd4a34fe4165a39960f40 Mon Sep 17 00:00:00 2001 From: Vladislav Sabanov Date: Mon, 26 May 2025 10:14:05 -0300 Subject: [PATCH 2/2] Make order --- CHANGELOG.md | 1 + lineman.cabal | 3 ++- src/App.hs | 3 ++- src/Concurrent.hs | 37 +++++++++++++++++++++++++++++++++++++ src/Types.hs | 32 +------------------------------- 5 files changed, 43 insertions(+), 33 deletions(-) create mode 100644 src/Concurrent.hs diff --git a/CHANGELOG.md b/CHANGELOG.md index cb56a71..3b0a5d2 100644 --- a/CHANGELOG.md +++ b/CHANGELOG.md @@ -7,6 +7,7 @@ The changelog is available [on GitHub][2]. * Add justfile * Update ci config +* Land concurrent action on `Ki` ## 1.0.2 diff --git a/lineman.cabal b/lineman.cabal index 8609b4c..0a7cb27 100644 --- a/lineman.cabal +++ b/lineman.cabal @@ -1,6 +1,6 @@ cabal-version: 3.0 name: lineman -version: 1.0.2 +version: 1.0.3 synopsis: traverse directory and run command description: Lineman traverses directory recursively and run command by condition @@ -55,6 +55,7 @@ library exposed-modules: App Cook + Concurrent Lineman Log Types diff --git a/src/App.hs b/src/App.hs index 67f3324..35342f6 100644 --- a/src/App.hs +++ b/src/App.hs @@ -5,7 +5,8 @@ module App ( import Cook (safeHead) import Lineman (launchAction) import Log (mkLogEnv) -import Types (App (unApp), Config (..), Env (..), forConcurrentlyKi) +import Types (App (unApp), Config (..), Env (..)) +import Concurrent (forConcurrentlyKi) -- import Control.Concurrent.Async.Lifted (forConcurrently) import Control.Exception.Safe (throwIO, tryAny) diff --git a/src/Concurrent.hs b/src/Concurrent.hs new file mode 100644 index 0000000..4f15845 --- /dev/null +++ b/src/Concurrent.hs @@ -0,0 +1,37 @@ +{-# LANGUAGE BlockArguments #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE TypeOperators #-} + +module Concurrent ( + forConcurrentlyKi, +) where + +import Control.Concurrent.STM (atomically) +import Control.Monad.Base (MonadBase (liftBase)) +import Control.Monad.IO.Class (MonadIO) +import Control.Monad.Trans.Control (MonadBaseControl, StM, control) +import Ki + +forConcurrentlyKi + :: (MonadBaseControl IO m, StM m (Ki.Thread b) ~ Ki.Thread b, StM m b ~ b, MonadIO m) + => [a] + -> (a -> m b) + -> m [b] +forConcurrentlyKi ns f = control $ \unlift -> scopedM \scope -> unlift $ do + threads <- mapM (forkM scope . f) ns + mapM (liftBase . atomically . Ki.await) threads + +forkM + :: (MonadBaseControl IO m, StM m (Ki.Thread a) ~ Ki.Thread a, StM m a ~ a) + => Ki.Scope + -> m a + -> m (Ki.Thread a) +forkM scope action = + control \unlift -> Ki.fork scope (unlift action) + +scopedM + :: (MonadBaseControl IO m, StM m a ~ a) + => (Ki.Scope -> m a) + -> m a +scopedM action = + control \unlift -> Ki.scoped \scope -> unlift (action scope) diff --git a/src/Types.hs b/src/Types.hs index 71158da..8f73ee8 100644 --- a/src/Types.hs +++ b/src/Types.hs @@ -6,12 +6,10 @@ {-# LANGUAGE GeneralizedNewtypeDeriving #-} {-# LANGUAGE InstanceSigs #-} {-# LANGUAGE KindSignatures #-} -{-# LANGUAGE LambdaCase #-} {-# LANGUAGE MultiParamTypeClasses #-} {-# LANGUAGE StandaloneDeriving #-} {-# LANGUAGE StrictData #-} {-# LANGUAGE BlockArguments #-} -{-# LANGUAGE TypeOperators #-} {-# LANGUAGE UndecidableInstances #-} {-# OPTIONS_GHC -fno-warn-orphans #-} @@ -21,7 +19,6 @@ module Types ( Conditions (..), Config (..), ActionMode, - forConcurrentlyKi, ) where import Control.Exception.Safe (MonadCatch, MonadMask, MonadThrow) @@ -33,16 +30,13 @@ import Control.Monad.Reader ( asks, local, ) -import Control.Monad.Trans.Control (MonadBaseControl, StM, control) -import Control.Monad.Base (MonadBase (liftBase)) +import Control.Monad.Trans.Control (MonadBaseControl) import Data.Set (Set) import Dhall (FromDhall (..)) import GHC.Generics (Generic) import GHC.IO.Exception (ExitCode (..)) import Katip (Katip (..), KatipContext (..), LogContexts, LogEnv (..), Namespace, Severity, Verbosity) import Path.Posix (Abs, Dir, Path) -import Ki -import Control.Concurrent.STM (atomically) newtype App a = MkApp @@ -114,27 +108,3 @@ data Conditions = Conditions } deriving stock (Eq, Show, Generic, Ord) deriving anyclass (FromDhall) - -forConcurrentlyKi :: - (MonadBaseControl IO m, StM m (Ki.Thread b) ~ Ki.Thread b, StM m b ~ b, MonadIO m) => - [a] -> - (a -> m b) -> - m [b] -forConcurrentlyKi ns f = control $ \unlift -> scopedM \scope -> unlift $ do - threads <- mapM (forkM scope . f) ns - mapM (liftBase . atomically . Ki.await) threads - -forkM :: - (MonadBaseControl IO m, StM m (Ki.Thread a) ~ Ki.Thread a, StM m a ~ a) => - Ki.Scope -> - m a -> - m (Ki.Thread a) -forkM scope action = - control \unlift -> Ki.fork scope (unlift action) - -scopedM :: - (MonadBaseControl IO m, StM m a ~ a) => - (Ki.Scope -> m a) -> - m a -scopedM action = - control \unlift -> Ki.scoped \scope -> unlift (action scope) \ No newline at end of file