Ki

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
 

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
@@ -66,14 +67,15 @@ library
     , extra
     , filepath
     , katip
-    , lifted-async
+    , ki
     , monad-control
     , mtl
     , path
     , path-io
     , pretty-simple
     , process
     , safe-exceptions
+    , stm
     , text
     , transformers-base
 

src/App.hs

@@ -6,8 +6,9 @@ import Cook (safeHead)
 import Lineman (launchAction)
 import Log (mkLogEnv)
 import Types (App (unApp), Config (..), Env (..))
+import Concurrent (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 +33,7 @@ appLineman = do
                             { envLogEnv = logEnv
                             , envActionMode =
                                 if cAsync config
-                                    then forConcurrently
+                                    then forConcurrentlyKi
                                     else forM
                             , envLogContext = mempty
                             , envLogNamespace = mempty
@@ -52,3 +53,4 @@ getConfig path = do
             pPrintString "Config parsing failed"
             throwIO err
         Right decoded -> pure decoded
+

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)

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

src/Types.hs

@@ -6,10 +6,10 @@
 {-# LANGUAGE GeneralizedNewtypeDeriving #-}
 {-# LANGUAGE InstanceSigs #-}
 {-# LANGUAGE KindSignatures #-}
-{-# LANGUAGE LambdaCase #-}
 {-# LANGUAGE MultiParamTypeClasses #-}
 {-# LANGUAGE StandaloneDeriving #-}
 {-# LANGUAGE StrictData #-}
+{-# LANGUAGE BlockArguments #-}
 {-# LANGUAGE UndecidableInstances #-}
 {-# OPTIONS_GHC -fno-warn-orphans #-}
 
@@ -38,6 +38,7 @@ import GHC.IO.Exception (ExitCode (..))
 import Katip (Katip (..), KatipContext (..), LogContexts, LogEnv (..), Namespace, Severity, Verbosity)
 import Path.Posix (Abs, Dir, Path)
 
+
 newtype App a = MkApp
     { unApp :: ReaderT Env IO a
     }
@@ -56,15 +57,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)