diff options
Diffstat (limited to 'src')
| -rw-r--r-- | src/Command/Run.hs | 36 | ||||
| -rw-r--r-- | src/Expression.hs | 74 |
2 files changed, 96 insertions, 14 deletions
diff --git a/src/Command/Run.hs b/src/Command/Run.hs index b26c265..63d1254 100644 --- a/src/Command/Run.hs +++ b/src/Command/Run.hs @@ -8,8 +8,8 @@ import Control.Exception import Control.Monad import Control.Monad.IO.Class +import Data.Char import Data.Containers.ListUtils -import Data.Either import Data.List import Data.Maybe import Data.Text (Text) @@ -225,6 +225,7 @@ watchExpressionSource expr = do root <- getJobRoot repo <- getDefaultRepo einputBase <- getEvalInput + let loop = isRangeExpressionDynamic expr let go running prev tmvar = do cur <- atomically $ do cur <- evaluateRange expr @@ -252,7 +253,11 @@ watchExpressionSource expr = do nextvar <- newEmptyTMVarIO atomically $ putTMVar tmvar $ Just ( jobsets, JobSource nextvar ) - go (reverse jobsets ++ keep) cur nextvar + if loop + then do + go (reverse jobsets ++ keep) cur nextvar + else do + atomically $ putTMVar nextvar Nothing liftIO $ do tmvar <- newEmptyTMVarIO @@ -299,28 +304,31 @@ cmdRun (RunCommand RunOptions {..} args) = do output <- getOutput storageDir <- getStorageDir - ( rangeOptions, jobOptions ) <- partitionEithers . concat <$> sequence + rangeOptions <- concat <$> sequence [ forM roRanges $ \range -> case T.splitOn ".." range of [ base, tip ] | not (T.null base) && not (T.null tip) - -> return $ Left ( Just base, tip ) + -> return ( Just base, tip ) _ -> tfail $ "invalid range: " <> range - , forM roSinceUpstream $ return . Left . ( Nothing, ) - , forM args $ \arg -> case T.splitOn ".." arg of - [ base, tip ] - | not (T.null base) && not (T.null tip) - -> return $ Left ( Just base, tip ) - [ _ ] -> return $ Right arg - _ -> tfail $ "invalid argument: " <> arg + , forM roSinceUpstream $ return . ( Nothing, ) ] - let ( refOptions, nameOptions ) = partition (T.elem '.') jobOptions + let ( nameOptions, jobOptions ) = partition (T.all $ \c -> isAlphaNum c || c == '_') args + ( refOptions, exprOptions ) = partition (\r -> "." `T.isInfixOf` r && not (".." `T.isInfixOf` r)) jobOptions argumentJobs <- argumentJobSource $ map JobName nameOptions refJobs <- refJobSource $ map parseJobRef refOptions + exprJobs <- forM exprOptions $ \trange -> + case parseRangeExpression trange of + Left err -> fail err + Right expr -> do + repo <- getDefaultRepo + range <- evaluateDeclaredRange repo expr + watchExpressionSource range + defaultSource <- getJobRoot >>= \case - _ | not (null rangeOptions && null roNewCommitsOn && null roNewTags && null jobOptions) -> do + _ | not (null rangeOptions && null roNewCommitsOn && null roNewTags && null args) -> do emptyJobSource JobRootRepo repo -> do @@ -344,7 +352,7 @@ cmdRun (RunCommand RunOptions {..} args) = do liftIO $ do mngr <- newJobManager storageDir optJobs - source <- mergeSources $ concat [ [ defaultSource, argumentJobs, refJobs ], ranges, branches, tags ] + source <- mergeSources $ concat [ [ defaultSource, argumentJobs, refJobs ], exprJobs, ranges, branches, tags ] mbHeaderLine <- mapM (flip newLine "") (outputTerminal output) threadCount <- newTVarIO (0 :: Int) diff --git a/src/Expression.hs b/src/Expression.hs index 6b1adc9..95ba815 100644 --- a/src/Expression.hs +++ b/src/Expression.hs @@ -9,14 +9,28 @@ module Expression ( evaluateDeclaredRevision, evaluateDeclaredRange, evaluateRevision, evaluateRange, getRangeCommits, getAddedRangeCommits, + + isRangeExpressionDynamic, + isRevisionExpressionDynamic, + + parseRangeExpression, ) where import Control.Concurrent.STM import Control.Monad.IO.Class +import Data.Bifunctor +import Data.Char import Data.Kind +import Data.List.NonEmpty qualified as NE import Data.Maybe +import Data.Proxy import Data.Text (Text) +import Data.Text qualified as T +import Data.Void + +import Text.Megaparsec +import Text.Megaparsec.Char import Job.Types import Output @@ -112,3 +126,63 @@ getAddedRangeCommits repo (CommitRange ar br) (CommitRange ar' br') = do (++) <$> listCommitsFrom repo a'b (catMaybes [ b' ]) -- added by moving B to B' <*> listCommitsFrom repo (catMaybes [ a' ]) (catMaybes [ a, b, b' ]) -- added by moving A to A' + + +isRangeExpressionDynamic :: RangeExpression -> Bool +isRangeExpressionDynamic = \case + RangeExpression x y -> isRevisionExpressionDynamic x || isRevisionExpressionDynamic y + +isRevisionExpressionDynamic :: RevisionExpression -> Bool +isRevisionExpressionDynamic = \case + StaticRef _ -> False + WatchedRef _ -> True + ModifiedRevision _ e -> isRevisionExpressionDynamic e + + +type ExprParser = Parsec Void Text + +parseRangeExpression :: Text -> Either String DeclaredRangeExpression +parseRangeExpression = bimap errorBundlePretty id . runParser parser "" + where + parser :: ExprParser DeclaredRangeExpression + parser = do + rev1 <- parseRevision + expr <- choice + [ do + _ <- string ".." + rev2 <- parseRevision + return $ RangeExpression rev2 rev1 + , do + return $ RangeExpression rev1 (ModifiedRevision "^" rev1) + ] + + (char ':' >> eof) <|> eof + return expr + + parseRevision :: ExprParser DeclaredRevisionExpression + parseRevision = do + tok <- fmap T.concat $ some $ choice + [ takeWhile1P Nothing (\x -> isAlphaNum x || x `elem` [ '_', '-', '/' ]) + , try $ string "." <* notFollowedBy (char '.') + ] + + rev <- choice + [ do + _ <- char '(' + arg <- takeWhileP Nothing (\x -> isAlphaNum x || x `elem` [ '_', '-', '/', '.' ]) + _ <- char ')' + case tok of + "watch" -> return $ WatchedRef arg + _ -> unexpected $ Tokens $ NE.fromList $ chunkToTokens @Text Proxy tok + + , do + return $ StaticRef tok + ] + + choice + [ do + suffix <- takeWhile1P Nothing (\x -> isNumber x || x `elem` [ '~', '^', '@', '{', '}' ]) + return $ ModifiedRevision suffix rev + , do + return rev + ] |