[Git][ghc/ghc][wip/bump-unix-filepath] Submodule linter: Allow references to tags

[Matthew Pickering (@mpickering)]

Matthew Pickering pushed to branch wip/bump-unix-filepath at Glasgow Haskell Compiler / GHC


Commits:
e3a3cb6a by Matthew Pickering at 2023-12-04T12:04:19+00:00
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.

- - - - -


2 changed files:

- linters/lint-submodule-refs/Main.hs
- linters/linters-common/Linters/Common.hs


Changes:

=====================================
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 False
+                (b:bs) -> do
+                  let more = case bs of
+                                [] -> ")"
+                                rest -> " and " <> T.pack (show (length rest)) <> " more)"
+                  T.putStrLn $ "... OK (" <>  b <> more
+                  return True
 
           if bad
             then exitWith (ExitFailure 1)
-            else T.putStrLn " OK"
+            else T.putStrLn "OK"
+


=====================================
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



View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/e3a3cb6a6f0fe195c1d542982a64de70cfb556cb

-- 
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/e3a3cb6a6f0fe195c1d542982a64de70cfb556cb
You're receiving this email because of your account on gitlab.haskell.org.


-------------- next part --------------
An HTML attachment was scrubbed...
URL: <http://mail.haskell.org/pipermail/ghc-commits/attachments/20231204/b82965c0/attachment-0001.html>