diff --git a/linters/lint-submodule-refs/Main.hs b/linters/lint-submodule-refs/Main.hs index a59ea2b9936d..c7e6b1ff4fd4 100644 --- a/linters/lint-submodule-refs/Main.hs +++ b/linters/lint-submodule-refs/Main.hs @@ -18,12 +18,12 @@ import System.Exit -- text import qualified Data.Text as T import qualified Data.Text.IO as T - ( putStrLn ) + ( putStrLn, putStr ) -- linters-common import Linters.Common ( GitType(..) - , gitBranchesContain, gitCatCommit, gitDiffTree, gitNormCid + , gitBranchesContain, gitIsTagged, gitCatCommit, gitDiffTree, gitNormCid ) -------------------------------------------------------------------------------- @@ -51,16 +51,18 @@ main = do exitWith (ExitFailure 1) bad <- fmap or $ forM smDeltas $ \(smPath,smCid) -> do - T.putStrLn $ " - " <> smPath <> " => " <> smCid + T.putStr $ " - " <> smPath <> " => " <> smCid let smAbsPath = dir ++ "/" ++ T.unpack smPath remoteBranches <- gitBranchesContain smAbsPath smCid + isTagged <- gitIsTagged smAbsPath smCid let (wip, nonWip) = partition ("wip/" `T.isPrefixOf`) originBranches originBranches = mapMaybe isOriginTracking remoteBranches isOriginTracking = T.stripPrefix "origin/" - let bad = null nonWip - when bad $ do + case (nonWip ++ isTagged) of + [] -> do + T.putStrLn " ... BAD" T.putStrLn $ " *FAIL* commit not found in submodule repo" T.putStrLn " or not reachable from persistent branches" T.putStrLn "" @@ -70,8 +72,15 @@ main = do commit <- gitNormCid smAbsPath ("origin/" <> branch) T.putStrLn $ " - " <> branch <> " -> " <> commit T.putStrLn "" - pure bad + return True + (b:bs) -> do + let more = case bs of + [] -> ")" + rest -> " and " <> T.pack (show (length rest)) <> " more)" + T.putStrLn $ "... OK (" <> b <> more + return False if bad then exitWith (ExitFailure 1) - else T.putStrLn " OK" + else T.putStrLn "OK" + diff --git a/linters/linters-common/Linters/Common.hs b/linters/linters-common/Linters/Common.hs index 8d92a877879d..b104b377acfd 100644 --- a/linters/linters-common/Linters/Common.hs +++ b/linters/linters-common/Linters/Common.hs @@ -1,6 +1,7 @@ {-# LANGUAGE BangPatterns #-} {-# LANGUAGE DerivingStrategies #-} {-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE ScopedTypeVariables #-} {-# OPTIONS_GHC -Wno-incomplete-uni-patterns #-} @@ -105,6 +106,10 @@ gitBranchesContain d ref = do return $!! map (T.drop 2) tmp +gitIsTagged :: FilePath -> GitRef -> Sh [Text] +gitIsTagged d ref = + T.lines <$> runGit d "tag" ["--points-at", ref] + -- | returns @[(path, (url, key))]@ -- -- may throw exception