add capture groups

README.md

@@ -4,15 +4,18 @@ Forked from **https://github.com/schell/steeloverseer**
 
 Changes from the original version:
 
-- Support for checking a single file, e.g. `sos foo.hs -c "ghc foo.hs"`
-- *Very* rudimentary automatic command inference based on file type, e.g. `sos foo.hs` will run "stack ghc foo.hs"
-- Somewhat simpler internals with no hard-coded 1s wait to batch commands (things just run right away)
-- *.sosrc* support, which is a YAML file that contains entries of the form:
+- Support for checking a single file, e.g. `sos foo.hs`
+- Capture groups in regex patterns, e.g. `sos . -c "gcc -c {0}" -p "(.*\.c)"`
+- Somewhat simplified internals with no hard-coded 1s wait to batch commands (things just run right away)
+- *.sosrc* support, which is a yaml file that contains entries such as:
 
-```yaml    
-- pattern: .*.txt
-  command: echo txt file changed
-- pattern: .*.php
-  command: echo php file changed
+```yaml
+- pattern: src/(.*)\.c
+  commands:
+  - make
+  - make test --file=test/{0}_test.c
+- pattern: (.*\.hs)
+  commands:
+  - hlint {0}
 ```
 (these entries are simply combined with the CLI-specified commands via `-p` and `-c`)

app/Main.hs

@@ -0,0 +1,187 @@
+{-# LANGUAGE FlexibleContexts  #-}
+{-# LANGUAGE LambdaCase        #-}
+{-# LANGUAGE OverloadedStrings #-}
+{-# LANGUAGE RecordWildCards   #-}
+
+module Main where
+
+import Command
+import Sos
+
+import Control.Concurrent
+import Control.Concurrent.Async
+import Control.Exception
+import Control.Monad
+import Data.ByteString        (ByteString)
+import Data.Monoid
+import Data.Yaml              (decodeFileEither, prettyPrintParseException)
+import Prelude                hiding (FilePath)
+import Options.Applicative
+import System.Console.ANSI
+import System.Console.Concurrent
+import System.Directory
+import System.Exit
+import System.FilePath
+import System.FSNotify
+import System.Process
+import Text.Regex.TDFA
+
+import qualified Data.ByteString.Char8 as BS
+
+version :: String
+version = "Steel Overseer 2.0"
+
+data Options = Options
+    { optTarget   :: FilePath
+    , optCommands :: [ByteString]
+    , optPatterns :: [ByteString]
+    } deriving Show
+
+-- A currently running command.
+type RunningCommand =
+    ( MVar (Async ()) -- Currently running command (might be finished)
+    , CommandPlan
+    )
+
+main :: IO ()
+main = execParser opts >>= main'
+  where
+    opts = info (helper <*> optsParser)
+        ( fullDesc
+       <> progDesc "A file watcher and development tool."
+       <> header version )
+
+    optsParser :: Parser Options
+    optsParser = Options
+        <$> strArgument
+            ( help "File or directory to watch for changes."
+           <> metavar "TARGET" )
+        <*> many (fmap BS.pack (strOption
+            ( long "command"
+           <> short 'c'
+           <> help "Add command to run on file event. (default: inferred)"
+           <> metavar "COMMAND" )))
+        <*> many (fmap BS.pack (strOption
+            ( long "pattern"
+           <> short 'p'
+           <> help "Add pattern to match on file path. Only relevant if the target is a directory. (default: .*)"
+           <> metavar "PATTERN" )))
+
+main' :: Options -> IO ()
+main' Options{..} = do
+    -- Parse .sosrc command plans.
+    rc_plans <- parseSosrc
+
+    -- Parse cli commands, where one command is created per pattern that
+    -- executes each of the specified sub-commands sequentially.
+    cli_plans <- do
+        let patterns =
+                case (rc_plans, optPatterns) of
+                    -- If there are no commands in .sosrc, and no patterns
+                    -- specified on the command line, default to ".*"
+                    ([], []) -> [".*"]
+                    _ -> optPatterns
+        runSos (mapM (\pattern -> buildCommandPlan pattern optCommands) patterns)
+
+    (target, plans) <- do
+        is_dir  <- doesDirectoryExist optTarget
+        is_file <- doesFileExist optTarget
+        case (is_dir, is_file) of
+            (True, _) -> pure (optTarget, cli_plans ++ rc_plans)
+            -- If the target is a single file, completely ignore the .sosrc
+            -- commands and the cli commands.
+            (_, True) -> do
+                plan <- runSos (buildCommandPlan (BS.pack optTarget) optCommands)
+                pure (takeDirectory optTarget, [plan])
+            _ -> do
+                putStrLn ("Target " ++ optTarget ++ " is not a file or directory.")
+                exitFailure
+
+    cwd <- getCurrentDirectory
+
+    outputConcurrentLn "Hit enter to quit."
+
+    withManager $ \wm -> do
+        runningCmds <- mapM (\plan -> do
+                                mv <- newMVar =<< async (pure ())
+                                pure (mv, plan))
+                            plans
+
+        let predicate = \event -> or (map (\plan -> match (cmdRegex plan) (eventPath event)) plans)
+        _ <- watchTree wm target predicate $ \event -> do
+            outputConcurrentLn ("\n" <> colored Cyan (showEvent event cwd))
+            mapM_ (handleEvent event cwd) runningCmds
+
+        _ <- getLine
+        mapM_ (\(mv, _) -> takeMVar mv >>= cancel) runningCmds
+
+handleEvent :: Event -> FilePath -> RunningCommand -> IO ()
+handleEvent event cwd (cmdThread, CommandPlan{..}) = do
+    let path = BS.pack (makeRelative cwd (eventPath event))
+    case match cmdRegex path of
+        [] -> pure ()
+        ((_:captures):_) -> do
+            commands <- runSos (mapM (\t -> instantiateTemplate t captures) cmdTemplates)
+
+            case commands of
+                [] -> pure ()
+                _ -> do
+                    a <- modifyMVar cmdThread $ \old_a -> do
+                        cancel old_a
+                        new_a <- async (runCommands commands)
+                        pure (new_a, new_a)
+                    _ <- waitCatch a
+                    pure ()
+
+runCommands :: [String] -> IO ()
+runCommands [] = pure ()
+runCommands (cmd:cmds) = do
+    success <- bracketOnError (runCommand cmd) (\ph -> terminateProcess ph >> pure False) $ \ph -> do
+        outputConcurrentLn (colored Magenta "\n> " <> cmd)
+
+        exitCode <- waitForProcess ph
+        case exitCode of
+            ExitSuccess -> do
+                outputConcurrentLn (colored Green "Success ✓")
+                pure True
+            _ -> do
+                outputConcurrentLn (colored Red "Failure ✗")
+                pure False
+    when success (runCommands cmds)
+
+--------------------------------------------------------------------------------
+
+-- Parse a list of command plans from .sosrc.
+parseSosrc :: IO [CommandPlan]
+parseSosrc = do
+    exists <- doesFileExist ".sosrc"
+    if exists
+        then
+            decodeFileEither ".sosrc" >>= \case
+                Left err -> do
+                    putStrLn ("Error parsing .sosrc:\n" ++ prettyPrintParseException err)
+                    exitFailure
+                Right raw_plans -> do
+                    plans <- runSos (mapM buildRawCommandPlan raw_plans)
+                    putStrLn ("Found " ++ show (length plans) ++ " commands in .sosrc")
+                    pure plans
+        else pure []
+
+--------------------------------------------------------------------------------
+
+colored :: Color -> String -> String
+colored c s = color c <> s <> reset
+
+color :: Color -> String
+color c = setSGRCode [SetColor Foreground Dull c]
+
+reset :: String
+reset = setSGRCode [Reset]
+
+outputConcurrentLn :: String -> IO ()
+outputConcurrentLn s = outputConcurrent (s <> "\n")
+
+showEvent :: Event -> FilePath -> String
+showEvent (Added fp _)    cwd = "Added "    ++ makeRelative cwd fp
+showEvent (Modified fp _) cwd = "Modified " ++ makeRelative cwd fp
+showEvent (Removed fp _)  cwd = "Removed "  ++ makeRelative cwd fp

src/Command.hs

@@ -0,0 +1,132 @@
+{-# LANGUAGE FlexibleContexts    #-}
+{-# LANGUAGE LambdaCase          #-}
+{-# LANGUAGE OverloadedStrings   #-}
+{-# LANGUAGE ScopedTypeVariables #-}
+
+module Command
+    ( CommandPlan(..)
+    , RawCommandPlan(..)
+    , buildCommandPlan
+    , buildRawCommandPlan
+    , instantiateTemplate
+    ) where
+
+import Sos
+
+import Control.Monad.Except
+import Data.Aeson.Types
+import Data.ByteString            (ByteString)
+import Data.Monoid
+import Data.Text                  (Text)
+import Text.Megaparsec
+import Text.Regex.TDFA
+import Text.Regex.TDFA.ByteString (compile)
+
+import qualified Data.Text.Encoding         as T
+import qualified Data.ByteString.Char8      as BS
+import qualified Data.ByteString.Lazy.Char8 as BSL
+import qualified Data.ByteString.Builder    as BS
+
+-- A Command is a shell command to run, e.g. "echo foo bar"
+type Command = String
+
+-- A CommandTemplate is a string that may contain anti-quoted capture groups.
+-- For example,
+--
+--    "gcc -c {0}.c -o {0}.c"
+--
+-- will become
+--
+--    [Right "gcc -c ", Left 0, Right ".c -o ", Left 0, Right ".c"]
+type CommandTemplate
+    = [Either Int ByteString]
+
+parseCommandTemplate :: MonadError SosException m => ByteString -> m CommandTemplate
+parseCommandTemplate template =
+    case runParser parser "" template of
+        Left err -> throwError (SosCommandParseException template err)
+        Right x  -> pure x
+  where
+    parser :: Parsec ByteString CommandTemplate
+    parser = some (Right <$> textPart
+          <|> Left  <$> capturePart)
+      where
+        textPart :: Parsec ByteString ByteString
+        textPart = BS.pack <$> some (satisfy (/= '{'))
+
+        capturePart :: Parsec ByteString Int
+        capturePart = between (char '{') (char '}') (read <$> some digitChar)
+
+-- Instantiate a template with a list of captured variables, per their indices.
+--
+-- For example,
+--
+--    instantiateTemplate [Right "foo", Left 0, Right "bar", Left 1] ["ONE", "TWO"] == "fooONEbarTWO"
+--
+instantiateTemplate :: forall m. MonadError SosException m => CommandTemplate -> [ByteString] -> m Command
+instantiateTemplate template0 vars0 = go 0 template0 vars0
+  where
+    go :: Int -> CommandTemplate -> [ByteString] -> m Command
+    go _ template [] =
+        case flattenTemplate template of
+            Left err -> throwError (SosCommandApplyException template0 vars0 err)
+            Right x  -> pure x
+    go n template (t:ts) = go (n+1) (map f template) ts
+      where
+        f :: Either Int ByteString -> Either Int ByteString
+        f (Left n')
+            | n == n'   = Right t
+            | otherwise = Left n'
+        f x = x
+
+-- Attempt to flatten a list of Rights to a single string.
+flattenTemplate :: CommandTemplate -> Either String Command
+flattenTemplate = go mempty
+  where
+    go :: BS.Builder -> CommandTemplate -> Either String Command
+    go acc [] = Right (BSL.unpack (BS.toLazyByteString acc))
+    go acc (Right x : xs) = go (acc <> BS.byteString x) xs
+    go _   (Left n : _) = Left ("uninstantiated template variable {" <> show n <> "}")
+
+-- A CommandPlan is a regex paired with a list of templates to execute on files
+-- that match the regex. Any mismatching of captured variables with the
+-- associated templates will be caught at runtime.
+--
+-- For example, this definition from a .sosrc yaml file is incorrect:
+--
+--     - pattern: (.*.c)
+--     - commands:
+--       - gcc -c {1}
+--
+-- because there is only one capture variable, and it has with index 0.
+--
+data CommandPlan = CommandPlan
+    { cmdPattern   :: ByteString        -- Text from which the regex was compiled.
+    , cmdRegex     :: Regex             -- Compiled regex of command pattern.
+    , cmdTemplates :: [CommandTemplate] -- Command template.
+    }
+
+-- Build a command plan from a "raw" command plan by compiling the regex and
+-- parsing each command template.
+buildCommandPlan :: forall m. MonadError SosException m => ByteString -> [ByteString] -> m CommandPlan
+buildCommandPlan pattern templates = CommandPlan
+    <$> pure pattern
+    <*> case compile defaultCompOpt defaultExecOpt pattern of
+            Left err -> throwError (SosRegexException pattern err)
+            Right x  -> pure x
+    <*> mapM parseCommandTemplate templates
+
+-- A "raw" CommandPlan that is post-processed after being parsed from a yaml
+-- file. Namely, the regex is compiled and the commands are parsed into
+-- templates.
+data RawCommandPlan = RawCommandPlan Text [Text]
+
+instance FromJSON RawCommandPlan where
+    parseJSON (Object o) = RawCommandPlan
+        <$> o .: "pattern"
+        <*> o .: "commands"
+    parseJSON v = typeMismatch "command" v
+
+buildRawCommandPlan :: forall m. MonadError SosException m => RawCommandPlan -> m CommandPlan
+buildRawCommandPlan (RawCommandPlan pattern templates) =
+    buildCommandPlan (T.encodeUtf8 pattern) (map T.encodeUtf8 templates)