steeloverseer 2.0.1.0 → 2.0.2.0
raw patch · 15 files changed
+634/−475 lines, 15 filesdep +exceptionsdep +manageddep +unixdep −resourcetdep ~aesondep ~processdep ~streaming
Dependencies added: exceptions, managed, unix
Dependencies removed: resourcet
Dependency ranges changed: aeson, process, streaming
Files
- README.md +21/−6
- app/Main.hs +171/−57
- src/Control/Concurrent/STM/TQueue/Extra.hs +153/−0
- src/Sos.hs +0/−76
- src/Sos/Exception.hs +5/−2
- src/Sos/FileEvent.hs +9/−2
- src/Sos/Job.hs +93/−71
- src/Sos/JobQueue.hs +0/−104
- src/Sos/Rule.hs +76/−46
- src/Sos/Template.hs +11/−14
- src/Sos/Utils.hs +1/−0
- src/System/FSNotify/Streaming.hs +16/−6
- steeloverseer.cabal +63/−54
- test/Sos/JobQueueSpec.hs +0/−23
- test/Sos/TemplateSpec.hs +15/−14
README.md view
@@ -3,6 +3,10 @@ A file watcher and development tool, similar to Ruby's [Guard](https://github.com/guard/guard). +The main idea is that you have steeloverseer watch your files and then execute a series of shell +commands in response. The first command to fail short circuits the series. The watched files can +be selected using regular expressions and the commands may include capture groups.+ [](https://travis-ci.org/steeloverseer/steeloverseer) Installation@@ -20,9 +24,10 @@ See `sos --help` to get started: - Steel Overseer 2.0.1+ Steel Overseer 2.0.2 Usage: sos [TARGET] [--rcfile ARG] [-c|--command COMMAND] [-p|--pattern PATTERN]+ [-e|--exclude PATTERN] A file watcher and development tool. Available options:@@ -34,16 +39,20 @@ -c,--command COMMAND Add command to run on file event. -p,--pattern PATTERN Add pattern to match on file path. Only relevant if the target is a directory. (default: .*)+ -e,--exclude PATTERN Add pattern to exclude matches on file path. Only+ relevant if the target is a directory. + Patterns and Commands ------------------- Capture groups can be created with `(` `)` and captured variables can be referred to with `\1`, `\2`, etc. (`\0` contains the entire match). -For example, for each change to a `.c` file in `src/`, we may want to compile-the file and run its corresponding unit test:+For example, for each change to a `.c` file in `src/` (excluding files+containing `"_test"`), we may want to compile the file and run its corresponding+unit test: - sos src/ -c "gcc -c \0 -o obj/\1.o" -c "make test --filter=test/\1_test.c" -p "src/(.*)\.c"+ sos src/ -c "gcc -c \0 -o obj/\1.o" -c "make test --filter=test/\1_test.c" -p "src/(.*)\.c" -e "_test" Commands are run left-to-right, and one failed command will halt the entire pipeline. @@ -54,6 +63,7 @@ ```yaml - pattern: src/(.*)\.c+ exclude: _test commands: - gcc -c \0 -o obj/\1.o - make test --filter=test/\1_test.c@@ -72,9 +82,14 @@ ### Grammar sosrc := [entry]- entry := { "pattern" | "patterns" : value | [value]- , "command" | "commands" : value | [value]+ entry := {+ pattern_entry,+ exclude_entry?, -- Note: optional!+ command_entry }+ pattern_entry := "pattern" | "patterns" : value | [value]+ exclude_entry := "exclude" | "excludes" | "excluding" : value | [value]+ command_entry := "command" | "commands" : value | [value] value := [segment] segment := text_segment | var_segment text_segment := string
app/Main.hs view
@@ -1,38 +1,53 @@+{-# OPTIONS_GHC -fno-warn-orphans #-}+ module Main where -import Sos+import Sos.FileEvent+import Sos.Job+import Sos.Rule+import Sos.Template import Sos.Utils -import qualified System.FSNotify.Streaming as FSNotify- import Control.Concurrent.Async+import Control.Monad.Catch (MonadThrow(..))+import Control.Monad.STM+import Control.Concurrent.STM.TMVar+import Control.Concurrent.STM.TQueue.Extra+import Control.Exception import Control.Monad-import Control.Monad.Except-import Data.ByteString (ByteString)-import Data.List.NonEmpty (NonEmpty(..))+import Control.Monad.Managed+import Data.ByteString (ByteString)+import Data.List.NonEmpty (NonEmpty(..)) import Data.Monoid-import Data.Yaml (decodeFileEither, prettyPrintParseException)+import Data.Yaml (decodeFileEither, prettyPrintParseException) import Options.Applicative import Streaming import System.Directory import System.Exit import System.FilePath-import System.IO+import Text.Printf (printf)+import Text.Regex.TDFA (match) -import qualified Data.Foldable as Foldable import qualified Streaming.Prelude as S-+import qualified System.FSNotify.Streaming as FSNotify version :: String-version = "Steel Overseer 2.0.1.0"+version = "Steel Overseer 2.0.2" data Options = Options { optTarget :: FilePath , optRCFile :: FilePath , optCommands :: [RawTemplate] , optPatterns :: [RawPattern]+ , optExcludes :: [RawPattern] } deriving Show +-- The concurrent sources of input to the main worker thread.+data Input+ = JobToEnqueue Job+ | JobToRun Job+ | JobResult Job (Maybe SomeException)+ main :: IO () main = execParser opts >>= main' where@@ -63,6 +78,11 @@ <> short 'p' <> help "Add pattern to match on file path. Only relevant if the target is a directory. (default: .*)" <> metavar "PATTERN" )))+ <*> many (fmap packBS (strOption+ ( long "exclude"+ <> short 'e'+ <> help "Add pattern to exclude matches on file path. Only relevant if the target is a directory."+ <> metavar "PATTERN" ))) main' :: Options -> IO () main' Options{..} = do@@ -72,24 +92,25 @@ -- Parse cli rules, where one rule is created per pattern that executes -- each of @optCommands@ sequentially. cli_rules <- do- let patterns :: [RawPattern]- patterns =+ let patterns, excludes :: [RawPattern]+ (patterns, excludes) = case (rc_rules, optPatterns) of -- If there are no commands in .sosrc, and no patterns -- specified on the command line, default to ".*"- ([], []) -> [".*"]- _ -> optPatterns- runSos (mapM (`buildRule` optCommands) patterns)+ ([], []) -> ([".*"], [])+ _ -> (optPatterns, optExcludes) + mapM (\pattrn -> buildRule pattrn excludes optCommands) patterns+ (target, rules) <- do is_dir <- doesDirectoryExist optTarget is_file <- doesFileExist optTarget case (is_dir, is_file) of (True, _) -> pure (optTarget, cli_rules ++ rc_rules) -- If the target is a single file, completely ignore the .sosrc- -- commands and the cli commands.+ -- commands. (_, True) -> do- rule <- runSos (buildRule (packBS optTarget) optCommands)+ rule <- buildRule (packBS optTarget) [] optCommands pure (takeDirectory optTarget, [rule]) _ -> do putStrLn ("Target " ++ optTarget ++ " is not a file or directory.")@@ -97,54 +118,132 @@ putStrLn "Hit Ctrl+C to quit." - job_queue <- newJobQueue+ all_job_events :: TQueue Job <- newTQueueIO - let enqueue_thread :: IO a+ let event_stream :: Stream (Of FileEvent) Managed ()+ event_stream = watchTree target++ job_stream :: Stream (Of Job) Managed ()+ job_stream =+ S.for event_stream+ (\event ->+ liftIO (eventCommands rules event) >>= \case+ [] -> pure ()+ (c:cs) -> S.yield (Job event (c :| cs)))++ enqueue_thread :: Managed () enqueue_thread =- runSos (sosEnqueueJobs rules (watchTree target) job_queue)+ S.mapM_ (liftIO . atomically . writeTQueue all_job_events) job_stream -- Run jobs forever, only stopping to prompt whether or not to run -- enqueued jobs when a job fails. This way, the failing job's output -- will not be lost by subsequent jobs' outputs without the user's -- consent. dequeue_thread :: IO a- dequeue_thread = forever $ do- dequeueJob job_queue >>= \case- JobSuccess -> pure ()- JobFailure -> do- jobQueueLength job_queue >>= \case- 0 -> pure ()- n -> do- putStrLn (yellow (show n ++ " job(s) still pending."))+ dequeue_thread = do+ -- Keep track of the subset of all job events to actually run. We don't+ -- want to enqueue already-enqueued jobs, for example - once is enough.+ jobs_to_run :: TQueue Job <- newTQueueIO - hSetBuffering stdin NoBuffering- continue <- fix (\prompt -> do- putStr (yellow "Press 'c' to continue, 'p' to print, or 'a' to abort: ")- hFlush stdout- (getChar <* putStrLn "") >>= \case- 'c' -> pure True- 'a' -> pure False- 'p' -> do- jobs <- jobQueueJobs job_queue- Foldable.forM_ (jobCommands <$> jobs) $- (\(c:|cs) -> do- putStrLn ("- " ++ c)- mapM_ (putStrLn . (" " ++)) cs)- prompt- _ -> prompt)- hSetBuffering stdin LineBuffering+ -- The second concurrent source of input: the result of the currently-+ -- running job, if any.+ running_job :: TMVar (Job, Async ()) <- newEmptyTMVarIO - unless continue $ do- n' <- jobQueueLength job_queue- clearJobQueue job_queue- putStrLn (red ("Aborted " ++ show n' ++ " job(s)."))+ let runJobAsync :: Job -> IO ()+ runJobAsync job = do+ putStrLn ("\n" <> cyan (showFileEvent (jobEvent job)))+ a <- async (runJob job)+ atomically (putTMVar running_job (job, a)) - race_ enqueue_thread dequeue_thread+ forever $ do+ let input1 :: STM Input+ input1 = JobToEnqueue <$> readTQueue all_job_events -watchTree- :: forall m a.- MonadResource m- => FilePath -> Stream (Of FileEvent) m a+ input2 :: STM Input+ input2 = do+ (job, a) <- takeTMVar running_job+ result <- waitCatchSTM a+ pure (JobResult job (either Just (const Nothing) result))++ input3 :: STM Input+ input3 =+ isEmptyTMVar running_job >>= \case+ True -> JobToRun <$> readTQueue jobs_to_run+ False -> retry++ atomically (input1 <|> input2 <|> input3) >>= \case+ -- A job event occurred. If it's equal to the running job, cancel it+ -- (it will be restarted when we process its ThreadKilled result).+ -- Otherwise, enqueue it if it doesn't already exist.+ JobToEnqueue job ->+ atomically (tryReadTMVar running_job) >>= \case+ Just (job', a) | job == job' -> do+ -- Slightly hacky here: replace the existing job with the new+ -- one, because although they contain the same commands, when+ -- we restart the job, we want to print the newer 'FileEvent',+ -- which may be different.+ _ <- atomically (swapTMVar running_job (job, a))+ cancel a+ _ ->+ atomically $+ elemTQueue jobs_to_run job >>= \case+ True -> pure ()+ False -> writeTQueue jobs_to_run job++ JobResult job (Just ex) -> do+ case fromException ex of+ -- The currently-running job died via ThreadKilled. We will+ -- assume we 'canceled' it to restart it.+ Just ThreadKilled -> runJobAsync job++ -- The currently-running job died via some other means. We don't+ -- want the output to get lost, so we'll just empty the job+ -- queue for simplicity.+ _ -> do+ putStrLn (prettyPrintException ex)++ let exhaustJobsToRun :: STM ()+ exhaustJobsToRun =+ tryReadTQueue jobs_to_run >>= \case+ Nothing -> pure ()+ Just _ -> exhaustJobsToRun++ atomically exhaustJobsToRun++ -- Job ended successfully!+ JobResult _ Nothing -> pure ()++ JobToRun job -> runJobAsync job++ race_ (runManaged enqueue_thread) dequeue_thread++eventCommands :: [Rule] -> FileEvent -> IO [ShellCommand]+eventCommands rules event = concat <$> mapM go rules+ where+ 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)++ where+ patternMatch :: [ByteString]+ patternMatch =+ case match (rulePattern rule) (fileEventPath event) of+ [] -> []+ xs:_ -> xs++ excludeMatch :: Bool+ excludeMatch =+ case ruleExclude rule of+ Nothing -> False+ Just exclude -> match exclude (fileEventPath event)++watchTree :: forall a. FilePath -> Stream (Of FileEvent) Managed a watchTree target = do cwd <- liftIO getCurrentDirectory @@ -152,7 +251,7 @@ config = FSNotify.defaultConfig { FSNotify.confDebounce = FSNotify.Debounce 0.1 } - stream :: Stream (Of FSNotify.Event) m a+ stream :: Stream (Of FSNotify.Event) Managed a stream = FSNotify.watchTree config target (const True) S.for stream (\case@@ -163,6 +262,13 @@ go :: FilePath -> FilePath -> ByteString go cwd path = packBS (makeRelative cwd path) +prettyPrintException :: SomeException -> String+prettyPrintException ex =+ case fromException ex of+ Just ExitSuccess -> red (printf "Failure ✗ (0)")+ Just (ExitFailure code) -> red (printf "Failure ✗ (%d)" code)+ Nothing -> red (show ex)+ -------------------------------------------------------------------------------- -- Parse a list of rules from an rcfile.@@ -173,12 +279,20 @@ then decodeFileEither sosrc >>= \case Left err -> do- putStrLn ("Error parsing " ++ show sosrc ++ ":\n" ++ prettyPrintParseException err)+ putStrLn ("Error parsing " ++ show sosrc ++ ":\n" +++ prettyPrintParseException err) exitFailure Right (raw_rules :: [RawRule]) -> do- rules <- runSos (mapM buildRawRule raw_rules)+ rules <- mapM buildRawRule raw_rules putStrLn (case length raw_rules of 1 -> "Found 1 rule in " ++ show sosrc n -> "Found " ++ show n ++ " rules in " ++ show sosrc) pure (concat rules) else pure []++--------------------------------------------------------------------------------+-- Orphan instances++instance MonadThrow Managed where+ throwM :: Exception e => e -> Managed a+ throwM e = managed (\_ -> throwM e)
+ src/Control/Concurrent/STM/TQueue/Extra.hs view
@@ -0,0 +1,153 @@+-- Source copied from Control.Concurrent.STM.TQueue. Exposes one additional+-- function (that can't be efficiently implemented with the existing API):+--+-- elemTQueue :: Eq a => TQueue a -> a -> STM Bool+--++{-# OPTIONS_GHC -fno-warn-name-shadowing #-}+{-# LANGUAGE CPP, DeriveDataTypeable #-}++#if __GLASGOW_HASKELL__ >= 701+{-# LANGUAGE Trustworthy #-}+#endif++-----------------------------------------------------------------------------+-- |+-- Module : Control.Concurrent.STM.TQueue+-- Copyright : (c) The University of Glasgow 2012+-- License : BSD-style (see the file libraries/base/LICENSE)+--+-- Maintainer : libraries@haskell.org+-- Stability : experimental+-- Portability : non-portable (requires STM)+--+-- A 'TQueue' is like a 'TChan', with two important differences:+--+-- * it has faster throughput than both 'TChan' and 'Chan' (although+-- the costs are amortised, so the cost of individual operations+-- can vary a lot).+--+-- * it does /not/ provide equivalents of the 'dupTChan' and+-- 'cloneTChan' operations.+--+-- The implementation is based on the traditional purely-functional+-- queue representation that uses two lists to obtain amortised /O(1)/+-- enqueue and dequeue operations.+--+-- @since 2.4+-----------------------------------------------------------------------------++module Control.Concurrent.STM.TQueue.Extra (+ -- * TQueue+ TQueue,+ newTQueue,+ newTQueueIO,+ readTQueue,+ tryReadTQueue,+ peekTQueue,+ tryPeekTQueue,+ writeTQueue,+ unGetTQueue,+ isEmptyTQueue,+ elemTQueue+ ) where++import GHC.Conc++import Data.Typeable (Typeable)++-- | 'TQueue' is an abstract type representing an unbounded FIFO channel.+--+-- @since 2.4+data TQueue a = TQueue {-# UNPACK #-} !(TVar [a])+ {-# UNPACK #-} !(TVar [a])+ deriving Typeable++instance Eq (TQueue a) where+ TQueue a _ == TQueue b _ = a == b++-- |Build and returns a new instance of 'TQueue'+newTQueue :: STM (TQueue a)+newTQueue = do+ read <- newTVar []+ write <- newTVar []+ return (TQueue read write)++-- |@IO@ version of 'newTQueue'. This is useful for creating top-level+-- 'TQueue's using 'System.IO.Unsafe.unsafePerformIO', because using+-- 'atomically' inside 'System.IO.Unsafe.unsafePerformIO' isn't+-- possible.+newTQueueIO :: IO (TQueue a)+newTQueueIO = do+ read <- newTVarIO []+ write <- newTVarIO []+ return (TQueue read write)++-- |Write a value to a 'TQueue'.+writeTQueue :: TQueue a -> a -> STM ()+writeTQueue (TQueue _read write) a = do+ listend <- readTVar write+ writeTVar write (a:listend)++-- |Read the next value from the 'TQueue'.+readTQueue :: TQueue a -> STM a+readTQueue (TQueue read write) = do+ xs <- readTVar read+ case xs of+ (x:xs') -> do writeTVar read xs'+ return x+ [] -> do ys <- readTVar write+ case ys of+ [] -> retry+ _ -> case reverse ys of+ [] -> error "readTQueue"+ (z:zs) -> do writeTVar write []+ writeTVar read zs+ return z++-- | A version of 'readTQueue' which does not retry. Instead it+-- returns @Nothing@ if no value is available.+tryReadTQueue :: TQueue a -> STM (Maybe a)+tryReadTQueue c = fmap Just (readTQueue c) `orElse` return Nothing++-- | Get the next value from the @TQueue@ without removing it,+-- retrying if the channel is empty.+peekTQueue :: TQueue a -> STM a+peekTQueue c = do+ x <- readTQueue c+ unGetTQueue c x+ return x++-- | A version of 'peekTQueue' which does not retry. Instead it+-- returns @Nothing@ if no value is available.+tryPeekTQueue :: TQueue a -> STM (Maybe a)+tryPeekTQueue c = do+ m <- tryReadTQueue c+ case m of+ Nothing -> return Nothing+ Just x -> do+ unGetTQueue c x+ return m++-- |Put a data item back onto a channel, where it will be the next item read.+unGetTQueue :: TQueue a -> a -> STM ()+unGetTQueue (TQueue read _write) a = do+ xs <- readTVar read+ writeTVar read (a:xs)++-- |Returns 'True' if the supplied 'TQueue' is empty.+isEmptyTQueue :: TQueue a -> STM Bool+isEmptyTQueue (TQueue read write) = do+ xs <- readTVar read+ case xs of+ (_:_) -> return False+ [] -> do ys <- readTVar write+ case ys of+ [] -> return True+ _ -> return False++elemTQueue :: Eq a => TQueue a -> a -> STM Bool+elemTQueue (TQueue read write) a = do+ xs <- readTVar read+ ys <- readTVar write+ return (elem a xs || elem a ys)
− src/Sos.hs
@@ -1,76 +0,0 @@-module Sos- ( Sos- , runSos- , sosEnqueueJobs- , module Sos.Exception- , module Sos.FileEvent- , module Sos.Job- , module Sos.JobQueue- , module Sos.Rule- , module Sos.Template- ) where--import Sos.Exception-import Sos.FileEvent-import Sos.Job-import Sos.JobQueue-import Sos.Rule-import Sos.Template--import Control.Applicative-import Control.Monad.Except-import Control.Monad.Trans.Resource-import Data.List.NonEmpty (NonEmpty(..))-import Streaming-import System.Exit-import Text.Regex.TDFA (match)--import qualified Streaming.Prelude as S---type Sos a = ResourceT (ExceptT SosException IO) a---- | Run an 'Sos' action in IO, exiting if any 'SosException's are thrown.-runSos :: Sos a -> IO a-runSos act =- runExceptT (runResourceT act) >>= \case- Left err -> do- print err- exitFailure- Right x -> return x---- | Enqueue jobs on the given job queue resulting from to apply the given--- rules to each emitted file event from the given stream. This function--- returns when the stream is exhausted.-sosEnqueueJobs- :: (Applicative m, MonadError SosException m, MonadResource m)- => [Rule]- -> Stream (Of FileEvent) m a- -> JobQueue- -> m a-sosEnqueueJobs rules events queue =- S.mapM_- (\(event, cmds) -> liftIO (enqueueJob event cmds queue))- (jobStream rules events)--jobStream- :: forall m a.- (Applicative m, MonadError SosException m)- => [Rule]- -> Stream (Of FileEvent) m a- -> Stream (Of (FileEvent, NonEmpty ShellCommand)) m a-jobStream rules events =- S.for events- (\event ->- lift (commands event) >>= \case- [] -> pure ()- (c:cs) -> S.yield (event, c :| cs))- where- commands :: FileEvent -> m [ShellCommand]- commands event = concat <$> mapM go rules- where- go :: Rule -> m [ShellCommand]- go rule =- case match (ruleRegex rule) (fileEventPath event) of- [] -> pure []- (xs:_) -> mapM (instantiateTemplate xs) (ruleTemplates rule)
src/Sos/Exception.hs view
@@ -4,8 +4,9 @@ import Sos.Utils +import Control.Exception (Exception) import Data.ByteString (ByteString)-+import Data.Typeable (Typeable) data SosException -- Error compiling the given regex.@@ -20,7 +21,7 @@ [Either Int ByteString] -- template [ByteString] -- captured variables String -- string reason for failure- deriving Eq+ deriving (Eq, Typeable) instance Show SosException where show (SosRegexException pattrn err) =@@ -35,3 +36,5 @@ (\case Left n -> '\\' : show n Right bs -> unpackBS bs)++instance Exception SosException
src/Sos/FileEvent.hs view
@@ -1,11 +1,13 @@-{-# LANGUAGE LambdaCase #-}- module Sos.FileEvent ( FileEvent(..) , fileEventPath+ , showFileEvent ) where +import Sos.Utils+ import Data.ByteString (ByteString)+import Data.Monoid ((<>)) data FileEvent = FileAdded ByteString@@ -15,3 +17,8 @@ fileEventPath = \case FileAdded path -> path FileModified path -> path++showFileEvent :: FileEvent -> String+showFileEvent = \case+ FileAdded path -> unpackBS ("Added: " <> path)+ FileModified path -> unpackBS ("Modified: " <> path)
src/Sos/Job.hs view
@@ -1,106 +1,128 @@+{-# LANGUAGE CPP #-}+ module Sos.Job- ( Job(jobEvent, jobCommands)- , JobResult(..)+ ( Job(..) , ShellCommand- , newJob , runJob- , restartJob- , unrestartJob- , shouldRestartJob ) where import Sos.FileEvent import Sos.Utils -import Control.Applicative-import Control.Concurrent.STM+import Control.Concurrent.MVar (readMVar) import Control.Exception-import Control.Monad-import Data.List.NonEmpty (NonEmpty)+import Data.Function (on)+import Data.List.NonEmpty (NonEmpty) import Data.Monoid import System.Exit+import System.IO+import System.IO.Error (tryIOError)+import System.Posix.Process (getProcessGroupID, getProcessGroupIDOf)+import System.Posix.Signals+ (Handler(Ignore), Signal, installHandler, sigTERM, sigTTOU,+ signalProcessGroup)+import System.Posix.Terminal (setTerminalProcessGroupID)+import System.Posix.Types (ProcessGroupID) import System.Process+import System.Process.Internals (ProcessHandle__(OpenHandle), phandle) import Text.Printf import qualified Data.List.NonEmpty as NonEmpty - type ShellCommand = String --data JobResult = JobSuccess | JobFailure----- | A 'Job' is an interruptible list of shell commands to run.+-- | 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.- , jobRestart :: TMVar ()- -- ^ A TMVar that, when written to, indicates this job should be- -- immediately canceled and restarted.+ { jobEvent :: FileEvent -- ^ Event that triggered this job.+ , jobCommands :: NonEmpty ShellCommand -- ^ The list of shell commands to run. } -newJob :: FileEvent -> NonEmpty ShellCommand -> STM Job-newJob event cmds = do- tmvar <- newEmptyTMVar- pure (Job event cmds tmvar)--restartJob :: Job -> STM ()-restartJob job = void (tryPutTMVar (jobRestart job) ())---- | Clear any previous restart "ping"s that were sent to this job while it was--- sitting in the job queue (not at the front).-unrestartJob :: Job -> STM ()-unrestartJob = void . tryTakeTMVar . jobRestart---- | An STM action that returns when this job should be restarted, and retries--- otherwise.-shouldRestartJob :: Job -> STM ()-shouldRestartJob = readTMVar . jobRestart+-- | Non-stanard Eq instance: Job equality compares only the shell commands it's+-- associated with.+instance Eq Job where+ (==) = (==) `on` jobCommands -- | Run a Job's list of shell commands sequentially. If a command returns--- ExitFailure, or an exception is thrown, don't run the rest (but also don't--- propagate the exception). Return whether or not all commands completed--- successfully.-runJob :: Job -> IO JobResult+-- ExitFailure, or an exception is thrown, propagate the exception.+runJob :: Job -> IO () runJob (NonEmpty.toList . jobCommands -> cmds0) = go 1 cmds0 where- go :: Int -> [ShellCommand] -> IO JobResult- go _ [] = pure JobSuccess+ go :: Int -> [ShellCommand] -> IO ()+ go _ [] = pure () go n (cmd:cmds) = do putStrLn (magenta (printf "[%d/%d] " n (length cmds0)) <> cmd) - let acquire :: IO ProcessHandle- acquire = do- (_, _, _, ph) <- createProcess (shell cmd)- pure ph+ let flushStdin :: IO ()+ flushStdin =+ hReady stdin >>= \case+ True -> getLine >> flushStdin+ False -> pure () - try (bracket acquire terminateProcess waitForProcess) >>= \case+ flushStdin++ try (runForegroundProcess (shell cmd)) >>= \case Left (ex :: SomeException) -> do- -- We expect to get ThreadKilled exceptions when we get canceled and- -- restarted. Any other exception would be bizarre; just print it and- -- move on.- case fromException ex of- Just ThreadKilled ->- case length cmds0 of- -- If this was a one-command job, just print that it's been- -- canceled. Otherwise, print a little graphic showing how much- -- of the job was completed before being restarted- 1 -> putStrLn (yellow ("Restarting job: " ++ cmd))- _ -> do- let (xs, ys) = splitAt (n-1) cmds0- putStrLn (yellow "Restarting job:")- mapM_ (putStrLn . yellow . printf "[✓] %s") xs- mapM_ (putStrLn . yellow . printf "[ ] %s") ys- _ -> putStrLn (red ("Exception: " ++ show ex))- pure JobFailure+ case fromException ex of+ Just ThreadKilled -> do+ putStrLn (yellow "Job interrupted ✗")+ throwIO ThreadKilled+ _ -> do+ putStrLn (red (show ex))+ throwIO ex Right ExitSuccess -> do putStrLn (green "Success ✓") go (n+1) cmds - Right (ExitFailure c) -> do- putStrLn (red (printf "Failure ✗ (%d)" c))- pure JobFailure+ Right (ExitFailure c) ->+ throwIO (ExitFailure c)++#ifdef mingw32_HOST_OS++runForegroundProcess :: CreateProcess -> IO ExitCode+runForegroundProcess c =+ bracket acquire release waitForProcess+ where+ acquire :: IO ProcessHandle+ acquire = do+ (_, _, _, ph) <- createProcess c { create_group = True }+ pure ph++ release :: ProcessHandle -> IO ()+ release ph = do+ _ <- tryIOError (interruptProcessGroupOf ph)+ terminateProcess ph++#else++runForegroundProcess :: CreateProcess -> IO ExitCode+runForegroundProcess c =+ bracket acquire release (\(ph, _) -> waitForProcess ph)+ where+ -- Create a process (inheriting all file descriptors) in a new process group+ -- and give it terminal access.+ acquire :: IO (ProcessHandle, ProcessGroupID)+ acquire = do+ (_, _, _, ph) <- createProcess (c { create_group = True })+ readMVar (phandle ph) >>= \case+ OpenHandle pid -> do+ pgid <- getProcessGroupIDOf pid+ setTerminalProcessGroupID 0 pgid+ pure (ph, pgid)+ _ -> error "Sos.Job.runForegroundProcess: unexpected process handle"++ -- Terminate a process and take back control of the terminal.+ release :: (ProcessHandle, ProcessGroupID) -> IO ()+ release (_, pgid) = do+ _ <- tryIOError (signalProcessGroup sigTERM pgid)+ getProcessGroupID >>= ignoring sigTTOU . setTerminalProcessGroupID 0++ ignoring :: Signal -> IO a -> IO a+ ignoring sig act =+ bracket+ (installHandler sig Ignore Nothing)+ (\handler -> installHandler sig handler Nothing)+ (\_ -> act)++#endif
− src/Sos/JobQueue.hs
@@ -1,104 +0,0 @@-module Sos.JobQueue- ( JobQueue- , newJobQueue- , clearJobQueue- , jobQueueLength- , jobQueueJobs- , enqueueJob- , dequeueJob- ) where--import Sos.FileEvent-import Sos.Job-import Sos.Utils--import Control.Applicative-import Control.Concurrent.Async-import Control.Concurrent.STM-import Data.Foldable (find)-import Data.List.NonEmpty (NonEmpty(..))-import Data.Monoid-import Data.Sequence (Seq, ViewL(..), (|>), viewl)--import qualified Data.Sequence as Sequence---- | A 'JobQueue' is a mutable linked list of jobs. The job at the head of the--- list is assumed to be currently running, however, it is left in the list so--- it can be interrupted and restarted.-newtype JobQueue = JobQueue (TVar (Seq Job))--newJobQueue :: IO JobQueue-newJobQueue = JobQueue <$> newTVarIO mempty--clearJobQueue :: JobQueue -> IO ()-clearJobQueue (JobQueue queue) = atomically (writeTVar queue mempty)--jobQueueLength :: JobQueue -> IO Int-jobQueueLength queue = Sequence.length <$> jobQueueJobs queue--jobQueueJobs :: JobQueue -> IO (Seq Job)-jobQueueJobs (JobQueue queue_tv) = atomically (readTVar queue_tv)--enqueueJob :: FileEvent -> NonEmpty ShellCommand -> JobQueue -> IO ()-enqueueJob event cmds (JobQueue queue_tv) = atomically $ do- queue <- readTVar queue_tv-- case find (\j -> jobCommands j == cmds) queue of- -- If the job is not already enqueued, enqueue it.- Nothing -> do- job <- newJob event cmds- writeTVar queue_tv (queue |> job)- -- Otherwise, if it's already been enqueued, put into its reset var.- -- This should only have an effect on the currently running job.- Just job -> restartJob job---- | Run the first job in the job queue, restarting it if signaled to do so.--- When this function returns, the job is popped off the job queue, and its--- result is returned.-dequeueJob :: JobQueue -> IO JobResult-dequeueJob (JobQueue queue_tv) = do- -- Read the first job, but don't actually pop it off of the queue- job <- atomically $ do- queue <- readTVar queue_tv- case viewl queue of- j :< _ -> do- unrestartJob j- pure j- _ -> retry-- putStrLn ("\n" <> cyan (showFileEvent (jobEvent job)))-- a <- async (runJob job)-- let doRunJob :: STM JobResult- doRunJob = do- r <- waitSTM a- -- seqTail is safe here because this is the only function that pops- -- jobs off of the job queue, and we already saw one job in the queue- -- above.- modifyTVar' queue_tv seqTail- pure r-- atomically (doRunJob <|||> shouldRestartJob job) >>= \case- -- Commands finished either successfully or unsuccessfully.- Left result -> pure result-- -- Another filesystem event triggered this list of commands- -- to be run again - cancel the previous run and start over.- Right () -> do- cancel a- _ <- waitCatch a- dequeueJob (JobQueue queue_tv)------------------------------------------------------------------------------------seqTail :: Seq a -> Seq a-seqTail s =- case viewl s of- _ :< xs -> xs- _ -> error "seqTail: empty sequence"--showFileEvent :: FileEvent -> String-showFileEvent = \case- FileAdded path -> unpackBS ("Added: " <> path)- FileModified path -> unpackBS ("Modified: " <> path)
src/Sos/Rule.hs view
@@ -10,14 +10,17 @@ import Sos.Template import Control.Applicative-import Control.Monad.Except+import Control.Monad.Catch (MonadThrow, throwM) import Data.Aeson.Types-import Data.ByteString (ByteString)+import Data.ByteString (ByteString)+import Data.ByteString.Internal (c2w) import Data.Either-import Data.Text (Text)+import Data.Foldable (asum)+import Data.Text (Text) import Text.Regex.TDFA import Text.Regex.TDFA.ByteString (compile) +import qualified Data.ByteString as ByteString (intercalate, singleton) import qualified Data.Text.Encoding as Text @@ -25,11 +28,12 @@ type RawPattern = ByteString --- A Rule 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.+-- A Rule is a pattern to match, optional pattern to exclude, and a list of+-- templates to execute on files that match the regex. ----- For example, this definition from a .sosrc yaml file is incorrect:+-- 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:@@ -38,63 +42,89 @@ -- because there is only one capture variable, and it has with index 0. -- data Rule = Rule- { ruleRegex :: Regex -- Compiled regex of command pattern.- , ruleTemplates :: [Template] -- Command template.+ { rulePattern :: Regex -- Compiled regex of file pattern.+ , ruleExclude :: Maybe Regex -- Compiled regex of file patterns to exclude.+ , ruleTemplates :: [Template] -- Command template. } --- Build a 'Rule' from a 'RawPattern' and a list of 'RawTemplate' by compiling--- the pattern regex and parsing each template.+-- Build a 'Rule' from a 'RawPattern', a list of 'RawPattern' (patterns to+-- exclude), and a list of 'RawTemplate' by:+--+-- - Compiling the pattern regex+-- - Compiling the exclude regexes combined with ||+-- - Parsing each template.+-- buildRule- :: forall m. MonadError SosException m- => RawPattern- -> [RawTemplate]- -> m Rule-buildRule pattrn templates0 = do+ :: forall m.+ MonadThrow m+ => RawPattern -> [RawPattern] -> [RawTemplate] -> m Rule+buildRule pattrn excludes templates0 = do templates <- mapM parseTemplate templates0 - -- Improve performance for patterns with no capture groups.- let (comp_opt, exec_opt) =- case concatMap lefts templates of- [] -> ( CompOption- { caseSensitive = True- , multiline = False- , rightAssoc = True- , newSyntax = True- , lastStarGreedy = True- }- , ExecOption- { captureGroups = False }- )- _ -> (defaultCompOpt, defaultExecOpt)- regex <-- case compile comp_opt exec_opt pattrn of- Left err -> throwError (SosRegexException pattrn err)- Right x -> return x+ -- 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 - return (Rule regex templates)+ case excludes of+ [] ->+ pure (Rule+ { rulePattern = regex+ , ruleExclude = Nothing+ , ruleTemplates = templates+ })+ _ -> do+ exclude <-+ compileRegex defaultCompOpt defaultExecOpt+ (ByteString.intercalate (ByteString.singleton (c2w '|')) excludes)+ pure (Rule+ { rulePattern = regex+ , ruleExclude = Just exclude+ , ruleTemplates = templates+ })+ where+ compileRegex :: CompOption -> ExecOption -> RawPattern -> m Regex+ compileRegex co eo patt =+ case compile co eo patt of+ Left err -> throwM (SosRegexException patt err)+ Right x -> pure x -- A "raw" Rule that is post-processed after being parsed from a yaml--- file. Namely, the regex is compiled and the commands are parsed into--- templates.-data RawRule = RawRule [RawPattern] [RawTemplate]+-- file.+data RawRule = RawRule [RawPattern] [RawPattern] [RawTemplate] instance FromJSON RawRule where- parseJSON (Object o) = RawRule <$> parsePatterns <*> parseCommands+ parseJSON (Object o) =+ RawRule <$> parsePatterns <*> parseExcludes <*> parseCommands where parsePatterns :: Parser [RawPattern]- parsePatterns = fmap go (o .: "pattern" <|> o .: "patterns")+ parsePatterns = go ["pattern", "patterns"] + parseExcludes :: Parser [RawPattern]+ parseExcludes = go ["exclude", "excludes", "excluding"] <|> pure []+ parseCommands :: Parser [RawTemplate]- parseCommands = fmap go (o .: "command" <|> o .: "commands")+ parseCommands = go ["command", "commands"] - go :: OneOrList Text -> [ByteString]- go = map Text.encodeUtf8 . listify+ go :: [Text] -> Parser [ByteString]+ go = fmap (map Text.encodeUtf8 . listify) . asum . map (o .:) parseJSON v = typeMismatch "command" v -buildRawRule :: forall m. MonadError SosException m => RawRule -> m [Rule]-buildRawRule (RawRule patterns templates) =- mapM (\pattrn -> buildRule pattrn templates) patterns+buildRawRule :: MonadThrow m => RawRule -> m [Rule]+buildRawRule (RawRule patterns excludes templates) =+ mapM (\pattrn -> buildRule pattrn excludes templates) patterns --------------------------------------------------------------------------------
src/Sos/Template.hs view
@@ -6,17 +6,17 @@ ) where import Sos.Exception-import Sos.Job (ShellCommand)+import Sos.Job (ShellCommand) import Sos.Utils import Control.Applicative-import Control.Monad.Except-import Data.ByteString (ByteString)+import Control.Monad.Catch (MonadThrow, throwM)+import Data.ByteString (ByteString) import Data.Monoid import Text.ParserCombinators.ReadP -import qualified Data.Text.Encoding as Text-import qualified Data.Text.Lazy as LText+import qualified Data.Text.Encoding as Text+import qualified Data.Text.Lazy as LText import qualified Data.Text.Lazy.Builder as LText @@ -38,11 +38,11 @@ type Template = [Either Int ByteString] -parseTemplate :: MonadError SosException m => RawTemplate -> m Template+parseTemplate :: MonadThrow m => RawTemplate -> m Template parseTemplate raw_template = case readP_to_S parser (unpackBS raw_template) of- [(template, "")] -> return template- _ -> throwError (SosCommandParseException raw_template)+ [(template, "")] -> pure template+ _ -> throwM (SosCommandParseException raw_template) where parser :: ReadP Template parser = some (capturePart <|||> textPart) <* eof@@ -63,10 +63,7 @@ -- instantiateTemplate ["ONE", "TWO"] [Right "foo", Left 0, Right "bar", Left 1] == "fooONEbarTWO" -- instantiateTemplate- :: forall m. MonadError SosException m- => [ByteString]- -> Template- -> m ShellCommand+ :: forall m. MonadThrow m => [ByteString] -> Template -> m ShellCommand instantiateTemplate vars0 template0 = go 0 vars0 template0 where go :: Int -> [ByteString] -> Template -> m ShellCommand@@ -74,8 +71,8 @@ case flattenTemplate template of Left n -> let err = "uninstantiated template variable: \\" ++ show n- in throwError (SosCommandApplyException template0 vars0 err)- Right x -> return x+ in throwM (SosCommandApplyException template0 vars0 err)+ Right x -> pure x go n (t:ts) template = go (n+1) ts (map f template) where f :: Either Int ByteString -> Either Int ByteString
src/Sos/Utils.hs view
@@ -10,6 +10,7 @@ (<|||>) :: Alternative f => f a -> f b -> f (Either a b) fa <|||> fb = Left <$> fa <|> Right <$> fb+infixl 3 <|||> -- The proper way to make a ByteString from a String - Data.ByteString.Char8 -- will snip each Char to 8 bits.
src/System/FSNotify/Streaming.hs view
@@ -11,18 +11,28 @@ ) where import Control.Concurrent.Chan+import Control.Exception (bracket) import Control.Monad-import Control.Monad.Trans.Resource+import Control.Monad.Managed import Streaming import Streaming.Prelude (yield) import System.FSNotify watchTree- :: MonadResource m- => WatchConfig -> FilePath -> (Event -> Bool) -> Stream (Of Event) m a+ :: WatchConfig -> FilePath -> (Event -> Bool) -> Stream (Of Event) Managed a watchTree config path predicate = do- chan <- liftIO newChan- (_, manager) <- allocate (startManagerConf config) stopManager- _ <- allocate (watchTreeChan manager path predicate chan) id+ chan <- liftIO newChan + manager <- lift (managed (withManagerConf config))++ lift (managed_ (withTreeChan manager path predicate chan))+ forever (liftIO (readChan chan) >>= yield)++withTreeChan+ :: WatchManager -> FilePath -> ActionPredicate -> EventChannel -> IO a -> IO a+withTreeChan manager path predicate chan act =+ bracket+ (watchTreeChan manager path predicate chan)+ id+ (\_ -> act)
steeloverseer.cabal view
@@ -1,14 +1,16 @@--- This file has been generated from package.yaml by hpack version 0.14.1.+-- This file has been generated from package.yaml by hpack version 0.20.0. -- -- see: https://github.com/sol/hpack+--+-- hash: e0468a343c9d01e573c139ad9fedc221aecdc503cfb35a1e36094f14f2b4e93c name: steeloverseer-version: 2.0.1.0+version: 2.0.2.0 cabal-version: >= 1.10 build-type: Simple license: BSD3 license-file: LICENSE-maintainer: efsubenovex@gmail.com+maintainer: schell@takt.com stability: stable homepage: https://github.com/schell/steeloverseer#readme bug-reports: https://github.com/schell/steeloverseer/issues@@ -27,64 +29,70 @@ library exposed-modules:- Sos+ Control.Concurrent.STM.TQueue.Extra Sos.Exception Sos.FileEvent Sos.Job- Sos.JobQueue Sos.Rule Sos.Template Sos.Utils System.FSNotify.Streaming+ other-modules:+ Paths_steeloverseer default-language: Haskell2010 build-depends:- async >= 2.0- , base >= 4.0 && < 5.0- , bytestring >= 0.10- , fsnotify >= 0.2- , mtl >= 2.2- , regex-tdfa >= 1.2- , resourcet >= 1.0- , semigroups >= 0.16- , stm >= 2.4- , streaming >= 0.1.0 && < 0.1.5- , text >= 1.2- , yaml >= 0.8- , aeson >= 0.8- , ansi-terminal >= 0.6.2- , containers >= 0.5- , process >= 1.2+ aeson >=0.8+ , ansi-terminal >=0.6.2+ , async >=2.0+ , base >=4.0 && <5.0+ , bytestring >=0.10+ , containers >=0.5+ , exceptions+ , fsnotify >=0.2+ , managed >=1.0.1+ , mtl >=2.2+ , process >=1.6 && <1.7+ , regex-tdfa >=1.2+ , semigroups >=0.16+ , stm >=2.4+ , streaming >=0.1.0 && <0.3+ , text >=1.2+ , unix+ , yaml >=0.8 hs-source-dirs: src- default-extensions: BangPatterns DeriveFunctor FlexibleContexts LambdaCase OverloadedStrings RecordWildCards ScopedTypeVariables ViewPatterns+ default-extensions: BangPatterns DeriveDataTypeable DeriveFunctor FlexibleContexts InstanceSigs LambdaCase OverloadedStrings RecordWildCards ScopedTypeVariables ViewPatterns ghc-options: -Wall executable sos main-is: Main.hs build-depends:- async >= 2.0- , base >= 4.0 && < 5.0- , bytestring >= 0.10- , fsnotify >= 0.2- , mtl >= 2.2- , regex-tdfa >= 1.2- , resourcet >= 1.0- , semigroups >= 0.16- , stm >= 2.4- , streaming >= 0.1.0 && < 0.1.5- , text >= 1.2- , yaml >= 0.8+ async >=2.0+ , base >=4.0 && <5.0+ , bytestring >=0.10+ , directory >=1.2+ , exceptions+ , filepath >=1.3+ , fsnotify >=0.2+ , managed >=1.0.1+ , mtl >=2.2+ , optparse-applicative >=0.11+ , regex-tdfa >=1.2+ , semigroups >=0.16 , steeloverseer- , directory >= 1.2- , filepath >= 1.3- , optparse-applicative >= 0.11+ , stm >=2.4+ , streaming >=0.1.0 && <0.3+ , text >=1.2+ , yaml >=0.8 if os(darwin) build-depends:- hfsevents >= 0.1.3+ hfsevents >=0.1.3+ other-modules:+ Paths_steeloverseer default-language: Haskell2010 hs-source-dirs: app- default-extensions: BangPatterns DeriveFunctor FlexibleContexts LambdaCase OverloadedStrings RecordWildCards ScopedTypeVariables ViewPatterns+ default-extensions: BangPatterns DeriveDataTypeable DeriveFunctor FlexibleContexts InstanceSigs LambdaCase OverloadedStrings RecordWildCards ScopedTypeVariables ViewPatterns ghc-options: -Wall -threaded test-suite spec@@ -92,24 +100,25 @@ main-is: Spec.hs hs-source-dirs: test- default-extensions: BangPatterns DeriveFunctor FlexibleContexts LambdaCase OverloadedStrings RecordWildCards ScopedTypeVariables ViewPatterns+ default-extensions: BangPatterns DeriveDataTypeable DeriveFunctor FlexibleContexts InstanceSigs LambdaCase OverloadedStrings RecordWildCards ScopedTypeVariables ViewPatterns ghc-options: -Wall build-depends:- async >= 2.0- , base >= 4.0 && < 5.0- , bytestring >= 0.10- , fsnotify >= 0.2- , mtl >= 2.2- , regex-tdfa >= 1.2- , resourcet >= 1.0- , semigroups >= 0.16- , stm >= 2.4- , streaming >= 0.1.0 && < 0.1.5- , text >= 1.2- , yaml >= 0.8- , steeloverseer+ async >=2.0+ , base >=4.0 && <5.0+ , bytestring >=0.10+ , exceptions+ , fsnotify >=0.2 , hspec+ , managed >=1.0.1+ , mtl >=2.2+ , regex-tdfa >=1.2+ , semigroups >=0.16+ , steeloverseer+ , stm >=2.4+ , streaming >=0.1.0 && <0.3+ , text >=1.2+ , yaml >=0.8 other-modules:- Sos.JobQueueSpec Sos.TemplateSpec+ Paths_steeloverseer default-language: Haskell2010
− test/Sos/JobQueueSpec.hs
@@ -1,23 +0,0 @@-module Sos.JobQueueSpec where--import Sos.FileEvent-import Sos.JobQueue--import Test.Hspec--import qualified Data.List.NonEmpty as NonEmpty--spec :: Spec-spec =- describe "enqueueJob" $ do- it "enqueues jobs" $ do- queue <- newJobQueue- enqueueJob (FileAdded "foo.txt") (NonEmpty.fromList ["a","b","c"]) queue- enqueueJob (FileAdded "bar.txt") (NonEmpty.fromList ["d","e","f"]) queue- jobQueueLength queue `shouldReturn` 2-- it "does not double-enqueue" $ do- queue <- newJobQueue- enqueueJob (FileAdded "foo.txt") (NonEmpty.fromList ["a","b","c"]) queue- enqueueJob (FileAdded "bar.txt") (NonEmpty.fromList ["a","b","c"]) queue- jobQueueLength queue `shouldReturn` 1
test/Sos/TemplateSpec.hs view
@@ -1,5 +1,6 @@ module Sos.TemplateSpec where +import Sos.Exception import Sos.Template import Test.Hspec@@ -8,27 +9,27 @@ spec = do describe "parseTemplate" $ do it "fails on the empty string" $- parseTemplate "" `shouldSatisfy` isLeft+ parseTemplate "" `shouldThrow` anySosException it "parses templates" $ do- parseTemplate "hi" `shouldBe` Right [Right "hi"]- parseTemplate "foo bar" `shouldBe` Right [Right "foo bar"]- parseTemplate "\\25" `shouldBe` Right [Left 25]- parseTemplate "gcc \\0" `shouldBe` Right [Right "gcc ", Left 0]+ 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] describe "instantiateTemplate" $ do it "ignores capture groups in templates with no captures" $ do- instantiateTemplate [] [Right "z"] `shouldBe` Right "z"- instantiateTemplate ["a"] [Right "z"] `shouldBe` Right "z"- instantiateTemplate ["a","b","c"] [Right "z"] `shouldBe` Right "z"+ instantiateTemplate [] [Right "z"] `shouldReturn` "z"+ instantiateTemplate ["a"] [Right "z"] `shouldReturn` "z"+ instantiateTemplate ["a","b","c"] [Right "z"] `shouldReturn` "z" it "substitutes capture groups" $ do- instantiateTemplate ["a","b","c"] [Left 2, Left 1, Left 0] `shouldBe` Right "cba"+ instantiateTemplate ["a","b","c"] [Left 2, Left 1, Left 0]+ `shouldReturn` "cba" it "errors when there are not enough capture groups" $ do- instantiateTemplate [] [Left 0] `shouldSatisfy` isLeft- instantiateTemplate ["a"] [Left 1] `shouldSatisfy` isLeft+ instantiateTemplate [] [Left 0] `shouldThrow` anySosException+ instantiateTemplate ["a"] [Left 1] `shouldThrow` anySosException -isLeft :: Either a b -> Bool-isLeft (Left _) = True-isLeft _ = False+anySosException :: Selector SosException+anySosException = const True