Parallel commands

app/Main.hs

@@ -216,18 +216,18 @@ main' Options{..} = do
 
   race_ (runManaged enqueue_thread) dequeue_thread
 
-eventCommands :: [Rule] -> FileEvent -> IO [ShellCommand]
+eventCommands :: [Rule] -> FileEvent -> IO [[ShellCommand]]
 eventCommands rules event = concat <$> mapM go rules
  where
-  go :: Rule -> IO [ShellCommand]
+  go :: Rule -> IO [[ShellCommand]]
   go rule =
     case (patternMatch, excludeMatch) of
       -- Pattern doesn't match
       ([], _) -> pure []
       -- Pattern matches, but so does exclude pattern
       (_, True) -> pure []
       -- Pattern matches, and exclude pattern doesn't!
-      (xs, False) -> mapM (instantiateTemplate xs) (ruleTemplates rule)
+      (xs, False) -> mapM (mapM (instantiateTemplate xs)) (ruleTemplates rule)
 
    where
     patternMatch :: [ByteString]

src/Sos/Job.hs

@@ -9,9 +9,11 @@ module Sos.Job
 import Sos.FileEvent
 import Sos.Utils
 
+import Control.Concurrent.Async (mapConcurrently)
 import Control.Concurrent.MVar (readMVar)
 import Control.Exception
 import Data.Function (on)
+import Data.List (find)
 import Data.List.NonEmpty (NonEmpty)
 import System.Exit
 import System.IO
@@ -33,8 +35,8 @@ type ShellCommand = String
 -- | A 'Job' is a list of shell commands to run, along with the 'FileEvent' that
 -- triggered the job.
 data Job = Job
-  { jobEvent    :: FileEvent             -- ^ Event that triggered this job.
-  , jobCommands :: NonEmpty ShellCommand -- ^ The list of shell commands to run.
+  { jobEvent    :: FileEvent               -- ^ Event that triggered this job.
+  , jobCommands :: NonEmpty [ShellCommand] -- ^ The list of lists of shell commands to run.
   }
 
 -- | Non-stanard Eq instance: Job equality compares only the shell commands it's
@@ -47,10 +49,10 @@ instance Eq Job where
 runJob :: Job -> IO ()
 runJob (NonEmpty.toList . jobCommands -> cmds0) = go 1 cmds0
  where
-  go :: Int -> [ShellCommand] -> IO ()
+  go :: Int -> [[ShellCommand]] -> IO ()
   go _ [] = pure ()
   go n (cmd:cmds) = do
-    putStrLn (magenta (printf "[%d/%d] " n (length cmds0)) <> cmd)
+    putStrLn (magenta (printf "[%d/%d] " n (length cmds0)) <> unlines cmd)
 
     let flushStdin :: IO ()
         flushStdin =
@@ -60,8 +62,8 @@ runJob (NonEmpty.toList . jobCommands -> cmds0) = go 1 cmds0
 
     flushStdin
 
-    try (runForegroundProcess (shell cmd)) >>= \case
-      Left (ex :: SomeException) -> do
+    try (mapConcurrently id (runForegroundProcess . shell <$> cmd)) >>= \case
+      Left (ex :: SomeException) ->
         case fromException ex of
           Just ThreadKilled -> do
             putStrLn (yellow "Job interrupted ✗")
@@ -70,12 +72,14 @@ runJob (NonEmpty.toList . jobCommands -> cmds0) = go 1 cmds0
             putStrLn (red (show ex))
             throwIO ex
 
-      Right ExitSuccess -> do
-        putStrLn (green "Success ✓")
-        go (n+1) cmds
-
-      Right (ExitFailure c) ->
-        throwIO (ExitFailure c)
+      Right exitCodes ->
+        case find (/= ExitSuccess) exitCodes of
+          Nothing -> do
+            putStrLn (green "Success ✓")
+            go (n+1) cmds
+          Just (ExitFailure c) ->
+            throwIO (ExitFailure c)
+          Just ExitSuccess -> undefined -- TODO: handle this in a better way
 
 #ifdef mingw32_HOST_OS
 

src/Sos/Rule.hs

@@ -44,7 +44,7 @@ type RawPattern = ByteString
 data Rule = Rule
   { rulePattern   :: Regex       -- Compiled regex of file pattern.
   , ruleExclude   :: Maybe Regex -- Compiled regex of file patterns to exclude.
-  , ruleTemplates :: [Template]  -- Command template.
+  , ruleTemplates :: [[Template]]  -- Command template.
   }
 
 -- Build a 'Rule' from a 'RawPattern', a list of 'RawPattern' (patterns to
@@ -59,24 +59,24 @@ buildRule
      MonadThrow m
   => RawPattern -> [RawPattern] -> [RawTemplate] -> m Rule
 buildRule pattrn excludes templates0 = do
-  templates <- mapM parseTemplate templates0
+  templates :: [[Template]] <- mapM parseTemplates templates0
 
   regex <-
     -- Improve performance for patterns with no capture groups.
-    case concatMap lefts templates of
-      [] ->
-        compileRegex
-          (CompOption
-            { caseSensitive  = True
-            , multiline      = False
-            , rightAssoc     = True
-            , newSyntax      = True
-            , lastStarGreedy = True
-            })
-          (ExecOption
-            { captureGroups = False })
-          pattrn
-      _ -> compileRegex defaultCompOpt defaultExecOpt pattrn
+    if all null (concatMap lefts <$> templates)
+    then
+      compileRegex
+        (CompOption
+          { caseSensitive  = True
+          , multiline      = False
+          , rightAssoc     = True
+          , newSyntax      = True
+          , lastStarGreedy = True
+          })
+        (ExecOption
+          { captureGroups = False })
+        pattrn
+    else compileRegex defaultCompOpt defaultExecOpt pattrn
 
   case excludes of
     [] ->

src/Sos/Template.hs

@@ -1,7 +1,7 @@
 module Sos.Template
   ( RawTemplate
   , Template
-  , parseTemplate
+  , parseTemplates
   , instantiateTemplate
   ) where
 
@@ -10,6 +10,7 @@ import Sos.Job (ShellCommand)
 import Sos.Utils
 
 import Control.Applicative
+import Control.Monad (liftM2)
 import Control.Monad.Catch (MonadThrow, throwM)
 import Data.ByteString (ByteString)
 import Text.ParserCombinators.ReadP
@@ -37,23 +38,28 @@ type RawTemplate = ByteString
 type Template = [Either Int ByteString]
 
 
-parseTemplate :: MonadThrow m => RawTemplate -> m Template
-parseTemplate raw_template =
+parseTemplates :: MonadThrow m => RawTemplate -> m [Template]
+parseTemplates raw_template =
   case readP_to_S parser (unpackBS raw_template) of
     [(template, "")] -> pure template
     _ -> throwM (SosCommandParseException raw_template)
  where
-  parser :: ReadP Template
-  parser = some (capturePart <|||> textPart) <* eof
+  parser :: ReadP [Template]
+  parser = sepBy1 parserSingle (string "|||") <* eof
+
+  parserSingle :: ReadP Template
+  parserSingle = some (capturePart <|||> textPart)
    where
     capturePart :: ReadP Int
     capturePart = read <$> (char '\\' *> munch1 digit)
      where
       digit :: Char -> Bool
       digit c = c >= '0' && c <= '9'
-
     textPart :: ReadP ByteString
-    textPart = packBS <$> munch1 (/= '\\')
+    textPart = packBS . concat <$> liftM2 (:) textNoPipePart (Text.ParserCombinators.ReadP.many $ liftM2 (++) (string "|" +++ string "||") textNoPipePart)
+     where
+      textNoPipePart :: ReadP String
+      textNoPipePart = munch1 (\s -> s /= '\\' && s /= '|')
 
 -- Instantiate a template with a list of captured variables, per their indices.
 --

test/Sos/TemplateSpec.hs

@@ -9,13 +9,17 @@ spec :: Spec
 spec = do
   describe "parseTemplate" $ do
     it "fails on the empty string" $
-      parseTemplate "" `shouldThrow` anySosException
+      parseTemplates "" `shouldThrow` anySosException
 
     it "parses templates" $ do
-      parseTemplate "hi"      `shouldReturn` [Right "hi"]
-      parseTemplate "foo bar" `shouldReturn` [Right "foo bar"]
-      parseTemplate "\\25"    `shouldReturn` [Left 25]
-      parseTemplate "gcc \\0" `shouldReturn` [Right "gcc ", Left 0]
+      parseTemplates "hi"             `shouldReturn` [[Right "hi"]]
+      parseTemplates "foo bar"        `shouldReturn` [[Right "foo bar"]]
+      parseTemplates "\\25"           `shouldReturn` [[Left 25]]
+      parseTemplates "gcc \\0"        `shouldReturn` [[Right "gcc ", Left 0]]
+      parseTemplates "hi|||there"     `shouldReturn` [[Right "hi"], [Right "there"]]
+      parseTemplates "\\25|||gcc \\0" `shouldReturn` [[Left 25], [Right "gcc ", Left 0]]
+      parseTemplates "hi|there"       `shouldReturn` [[Right "hi|there"]]
+      parseTemplates "hi||there"      `shouldReturn` [[Right "hi||there"]]
 
   describe "instantiateTemplate" $ do
     it "ignores capture groups in templates with no captures" $ do