Submodule linter: Allow references to tags

We modify the submodule linter so that if the bumped commit is a
specific tag then the commit is accepted.

Fixes #24241

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"
+

linters/linters-common/Linters/Common.hs

 {-# 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