+.nix:

+  image: nixos/nix:2.25.2

+  variables:

+    LANG: "C.UTF-8"

+  before_script:

+    - echo "experimental-features = nix-command flakes" >> /etc/nix/nix.conf

+    # Note [Nix-in-Docker]

+    # ~~~~~~~~~~~~~~~~~~~~

+    # The nixos/nix default config is max-jobs=1 and cores=$(logical

+    # cores num) which doesn't play nice with our $CPUS convention. We

+    # fix it before invoking any nix build to avoid oversubscribing

+    # while allowing a reasonable degree of parallelism.

+    # FIXME: Disabling build-users-group=nixbld is a workaround for a Nix-in-Docker issue. See

+    # https://gitlab.haskell.org/ghc/head.hackage/-/issues/38#note_560487 for

+    # discussion.

+    - echo "cores = $CPUS" >> /etc/nix/nix.conf

+    - echo "max-jobs = $CPUS" >> /etc/nix/nix.conf

+    - nix run nixpkgs#gnused -- -i -e 's/ nixbld//' /etc/nix/nix.conf

+

+lint-boot-tags:

+  extends: [.lint, .nix]

+  script:

+    - nix run ./utils/check-submodules# -- check-tags

+  rules:

+    - if: $RELEASE_JOB

+      allow_failure: false

+    - allow_failure: true

+

+lint-boot-versions:

+  extends: [.lint, .nix]

+  script:

+    - nix run ./utils/check-submodules# -- check-versions

+  rules:

+    - if: $RELEASE_JOB

+      allow_failure: false

+    - allow_failure: true

+

+  extends: [.lint, .nix]

+Copyright (c) 2024, Ben Gamari

+

+All rights reserved.

+

+Redistribution and use in source and binary forms, with or without

+modification, are permitted provided that the following conditions are met:

+

+    * Redistributions of source code must retain the above copyright

+      notice, this list of conditions and the following disclaimer.

+

+    * Redistributions in binary form must reproduce the above

+      copyright notice, this list of conditions and the following

+      disclaimer in the documentation and/or other materials provided

+      with the distribution.

+

+    * Neither the name of Ben Gamari nor the names of other

+      contributors may be used to endorse or promote products derived

+      from this software without specific prior written permission.

+

+THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS

+"AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT

+LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR

+A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT

+OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL,

+SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT

+LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE,

+DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY

+THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT

+(INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE

+OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.

+# check-submodules

+

+This is a utilities used in GHC CI to verify the consistency and

+up-to-date-ness of GHC's boot library dependencies. Specifically

+we verify that:

+

+ * the referenced commits are released on Hackage

+ * that the Hackage version has not been deprecated

+ * that there is not a more recent version in the same major series

+

+## Usage

+

+In the GHC tree:

+```bash

+nix run ./utils/check-submodules#

+```

+module Main (main) where

+

+import CheckVersions

+import CheckTags

+import System.Environment (getArgs)

+

+main :: IO ()

+main = do

+  args <- getArgs

+  case args of

+    ["check-versions"] -> checkVersions

+    ["check-tags"] -> checkTags

+    ["summarize"] -> summarize

+    ["email"] -> maintainerEmails >>= putStrLn

+    _ -> fail "invalid mode (valid modes: check-versions, check-tags, summarize, email)"

+cabal-version:      3.0

+name:               check-submodules

+version:            0.1.0.0

+-- synopsis:

+-- description:

+homepage:           https://gitlab.haskell.org/ghc/ghc

+license:            BSD-3-Clause

+license-file:       LICENSE

+author:             Ben Gamari

+maintainer:         ben@smart-cactus.org

+copyright:          (c) 2024 Ben Gamari

+category:           Development

+build-type:         Simple

+-- extra-source-files:

+

+common warnings

+    ghc-options: -Wall

+

+executable check-submodules

+    import:           warnings

+    main-is:          Main.hs

+    build-depends:    base,

+                      check-submodules

+    hs-source-dirs:   app

+    default-language: Haskell2010

+

+library

+    import:           warnings

+    exposed-modules:  Git,

+                      Hackage,

+                      CheckVersions,

+                      CheckTags,

+                      Packages,

+                      Package,

+                      Pretty

+    build-depends:    base,

+                      wreq,

+                      aeson,

+                      bytestring,

+                      text,

+                      transformers,

+                      prettyprinter,

+                      prettyprinter-ansi-terminal,

+                      filepath,

+                      microlens,

+                      containers,

+                      typed-process,

+                      Cabal

+    hs-source-dirs:   src

+    default-language: Haskell2010

+{

+  "nodes": {

+    "flake-utils": {

+      "inputs": {

+        "systems": "systems"

+      },

+      "locked": {

+        "lastModified": 1731533236,

+        "narHash": "sha256-l0KFg5HjrsfsO/JpG+r7fRrqm12kzFHyUHqHCVpMMbI=",

+        "owner": "numtide",

+        "repo": "flake-utils",

+        "rev": "11707dc2f618dd54ca8739b309ec4fc024de578b",

+        "type": "github"

+      },

+      "original": {

+        "owner": "numtide",

+        "repo": "flake-utils",

+        "type": "github"

+      }

+    },

+    "nixpkgs": {

+      "locked": {

+        "lastModified": 1734083684,

+        "narHash": "sha256-5fNndbndxSx5d+C/D0p/VF32xDiJCJzyOqorOYW4JEo=",

+        "path": "/nix/store/0xbni69flk8380w0apw4h640n37wn1i9-source",

+        "rev": "314e12ba369ccdb9b352a4db26ff419f7c49fa84",

+        "type": "path"

+      },

+      "original": {

+        "id": "nixpkgs",

+        "type": "indirect"

+      }

+    },

+    "root": {

+      "inputs": {

+        "flake-utils": "flake-utils",

+        "nixpkgs": "nixpkgs"

+      }

+    },

+    "systems": {

+      "locked": {

+        "lastModified": 1681028828,

+        "narHash": "sha256-Vy1rq5AaRuLzOxct8nz4T6wlgyUR7zLU309k9mBC768=",

+        "owner": "nix-systems",

+        "repo": "default",

+        "rev": "da67096a3b9bf56a91d16901293e51ba5b49a27e",

+        "type": "github"

+      },

+      "original": {

+        "owner": "nix-systems",

+        "repo": "default",

+        "type": "github"

+      }

+    }

+  },

+  "root": "root",

+  "version": 7

+}

+{

+  description = "GHC boot library linting";

+

+  inputs.flake-utils.url = "github:numtide/flake-utils";

+

+  outputs = { self, nixpkgs, flake-utils }:

+    flake-utils.lib.eachDefaultSystem (system:

+      let pkgs = nixpkgs.legacyPackages.${system}; in

+      {

+        packages = rec {

+          check-submodules = pkgs.haskellPackages.callCabal2nix "generate-ci" ./. {};

+          default = check-submodules;

+        };

+

+        devShells.default = self.packages.${system}.default.env;

+

+        apps = rec {

+          check-submodules = flake-utils.lib.mkApp {

+            drv = self.packages.${system}.check-submodules;

+          };

+          default = check-submodules;

+        };

+      }

+    );

+}

+

+cradle:

+  cabal:

+{-# LANGUAGE ImportQualifiedPost #-}

+{-# LANGUAGE OverloadedStrings #-}

+{-# LANGUAGE TupleSections #-}

+

+module CheckTags

+    ( checkTags

+    ) where

+

+import Data.List (isPrefixOf, isSuffixOf)

+import Git qualified

+import Package (Package(..))

+import Packages (packages)

+import Pretty

+import Control.Monad (unless)

+

+findReleaseTag :: Git.GitRepo -> Package -> IO (Maybe Git.Tag)

+findReleaseTag repo pkg = do

+    allTags <- Git.reachableTags repo "HEAD"

+    case filter (\tag -> pkgIsReleaseTag pkg tag || isGhcTag tag) allTags of

+      [] -> return Nothing

+      tag:_ -> return (Just tag)

+

+isGhcTag :: Git.Tag -> Bool

+isGhcTag tag = "-ghc" `isSuffixOf` tag

+

+checkTag :: Git.GitRepo -> Package -> IO (Maybe Doc)

+checkTag repo pkg = do

+    mb_tag <- findReleaseTag repo pkg

+    case mb_tag of

+      Nothing -> return $ Just "No release tags found"

+      Just tag -> checkChanges repo tag

+

+-- | Check whether the tag only deviates from HEAD in trivial ways.

+checkChanges :: Git.GitRepo -> Git.Ref -> IO (Maybe Doc)

+checkChanges repo tag = do

+    files <- Git.changedFiles repo tag "HEAD"

+    case filter (not . okayChange) files of

+      [] -> return Nothing

+      badFiles  -> do

+          described <- Git.describeRef repo "HEAD"

+          let msg = vsep

+                [ "Tag" <+> ppCommit (pretty tag) <+> "differs from" <+> ppCommit (pretty described) <+> "in:"

+                , bulletList fileList

+                ]

+              maxFiles = 5

+              fileList

+                | n > 0 =

+                    take maxFiles (map pretty badFiles) ++

+                    ["... and" <+> pretty n <+> "other" <+> plural "file" "files" n]

+                | otherwise = map pretty badFiles

+                where n = length badFiles - maxFiles

+          return $ Just msg

+

+okayChange :: FilePath -> Bool

+okayChange path

+  | "." `isPrefixOf` path = True

+  | ".gitignore" `isSuffixOf` path = True

+  | otherwise = False

+

+checkTags :: IO ()

+checkTags = do

+    let ghcRepo = Git.GitRepo "."

+    errs <- mapM (\pkg -> (pkg,) <$> checkTag (Git.submoduleIn ghcRepo (pkgPath pkg)) pkg) packages

+    putDoc $ bulletList

+      [ severityIcon Error <+> ppPackage pkg <> ":" <+> err

+      | (pkg, Just err) <- errs

+      ]

+    unless (null errs) $ fail "Tag issues above"

+{-# LANGUAGE ImportQualifiedPost #-}

+{-# LANGUAGE OverloadedStrings #-}

+{-# LANGUAGE TupleSections #-}

+

+module CheckVersions

+    ( checkVersions

+    , summarize

+    , maintainerEmails

+    ) where

+

+import Control.Monad (forM_)

+import Control.Monad.IO.Class

+import Control.Monad.Trans.Writer

+import Data.Function (on)

+import Data.List (intercalate, sort, nubBy)

+import Data.Map.Strict qualified as M

+import Data.Text qualified as T

+import Data.Version

+import Distribution.Types.PackageName qualified as C

+import System.Exit

+

+import Hackage (getVersions, PackageState (..))

+import Pretty

+import Package

+import Packages

+

+isPvpCompatible :: Version -> Version -> Bool

+isPvpCompatible a b =

+    take 2 (versionBranch a) == take 2 (versionBranch b)

+

+updateVersion :: M.Map Version PackageState -> Version -> Maybe Version

+updateVersion available v

+  | [] <- compatible = Nothing

+  | otherwise        = Just $ maximum compatible

+  where

+    compatible =

+      [ v'

+      | (v', Normal) <- M.assocs available -- non-deprecated versions available via Hackage...

+      , v' > v                             -- that are newer than the submodule...

+      , v' `isPvpCompatible` v             -- and are compatible with the submodule

+      ]

+

+checkPackage :: Package -> WriterT [(Severity, Doc)] IO ()

+checkPackage pkg = do

+    v <- liftIO $ getPackageVersion pkg

+    available <- liftIO $ getVersions (pkgName pkg)

+

+    case M.lookup v available of

+        Nothing         -> tellMsg Error $ "Version" <+> ppVersion v <+> "is not on Hackage"

+        Just Deprecated -> tellMsg Error $ "Version" <+> ppVersion v <+> "has been deprecated"

+        Just Normal     -> return ()

+

+    case updateVersion available v of

+        Nothing -> return ()

+        Just v' -> tellMsg Warning $ "Shipping with" <+> ppVersion v <+> "but newer version" <+> ppVersion v' <+> "is available"

+

+tellMsg :: Severity -> Doc -> WriterT [(Severity, Doc)] IO ()

+tellMsg sev msg = tell [(sev, msg)]

+

+summarizeSubmodules :: [Package] -> IO ()

+summarizeSubmodules pkgs = forM_ pkgs $ \pkg -> do

+    v <- getPackageVersion pkg

+    putStrLn $ "    " <> C.unPackageName (pkgName pkg) <> " " <> showVersion v <> " @ " <> pkgPath pkg

+

+maintainerEmails :: IO String

+maintainerEmails = do

+    maintainers <- concat <$> mapM getPackageMaintainers packages

+    return $ intercalate ", " $ map (T.unpack . contactRecipient) $ nubBy ((==) `on` contactEmail) $ sort maintainers

+

+summarize :: IO ()

+summarize =

+    summarizeSubmodules packages

+

+checkVersions :: IO ()

+checkVersions = do

+    errs <- mapM (\pkg -> map (pkg, ) <$> execWriterT (checkPackage pkg)) packages

+    putDoc $ bulletList

+      [ severityIcon sev <+> ppPackage pkg <> ":" <+> err

+      | (pkg, (sev, err)) <- concat errs

+      ]

+    exitWith $ if null errs then ExitSuccess else ExitFailure 1

+

+{-# LANGUAGE ImportQualifiedPost #-}

+

+module Git

+    ( GitRepo(..)

+    , submoduleIn

+

+    , Ref

+    , describeRef

+    , submoduleCommit

+    , Tag

+    , reachableTags

+    , changedFiles

+    ) where

+

+import System.Process.Typed

+import Data.ByteString.Lazy.Char8 qualified as BSL

+import System.FilePath ((</>))

+

+newtype GitRepo = GitRepo { gitRepoPath :: FilePath }

+

+submoduleIn :: GitRepo -> FilePath -> GitRepo

+submoduleIn (GitRepo path) submod =

+    GitRepo $ path </> submod

+

+type Ref = String

+type Tag = String

+

+runGit :: GitRepo -> [String] -> IO BSL.ByteString

+runGit (GitRepo path) args = do

+    readProcessStdout_ $ setWorkingDir path (proc "git" args)

+

+describeRef :: GitRepo -> Ref -> IO String

+describeRef repo ref =

+    head . lines . BSL.unpack <$> runGit repo ["describe", "--always", ref]

+

+-- | Get the commit of the given submodule.

+submoduleCommit :: GitRepo -> FilePath -> IO Ref

+submoduleCommit repo submodule = do

+    out <- runGit repo ["submodule", "status", submodule]

+    case BSL.words $ BSL.drop 1 out of

+      commit:_ -> return $ BSL.unpack commit

+      _ -> fail "Unrecognized output from `git submodule status`"

+

+-- | Get the most recent tags reacheable from the given commit.

+reachableTags :: GitRepo -> Ref -> IO [Tag]

+reachableTags repo ref =

+    reverse . map BSL.unpack . BSL.lines <$> runGit repo ["tag", "--sort=taggerdate", "--merged", ref]

+

+changedFiles :: GitRepo -> Ref -> Ref -> IO [FilePath]

+changedFiles repo a b = do

+    map BSL.unpack . BSL.lines <$> runGit repo ["diff", "--name-only", a, b]

+

+{-# LANGUAGE LambdaCase #-}

+{-# LANGUAGE OverloadedStrings #-}

+

+module Hackage

+    ( PackageState(..)

+    , getVersions

+    ) where

+

+import qualified Data.Map.Strict as M

+import Lens.Micro

+import Network.Wreq

+import Distribution.Types.PackageName

+import qualified Data.Aeson as JSON

+import Data.Version

+

+data PackageState = Normal | Deprecated

+    deriving (Show)

+

+instance JSON.FromJSON PackageState where

+    parseJSON = JSON.withText "package state" $ \case

+        "normal" -> pure Normal

+        "deprecated" -> pure Deprecated

+        _ -> fail "unknown PackageState"

+

+getVersions :: PackageName -> IO (M.Map Version PackageState)

+getVersions pn = do

+    r <- asJSON =<< getWith opts url

+    maybe (fail "getVersions: failed") pure (r ^? responseBody)

+  where

+    opts = defaults & header "Accept" .~ ["application/json"]

+    url = "https://hackage.haskell.org/package/" <> unPackageName pn

+

+{-# LANGUAGE ImportQualifiedPost #-}

+{-# LANGUAGE OverloadedStrings #-}

+

+module Package

+  ( Contact(..)

+  , parseContact

+  , contactRecipient

+

+  , Package(..)

+  , getPackageVersion

+  , getPackageMaintainers

+  ) where

+

+import Data.ByteString qualified as BS

+import Data.Text qualified as T

+import Data.Version

+import Distribution.PackageDescription.Parsec qualified as C

+import Distribution.Types.GenericPackageDescription qualified as C

+import Distribution.Types.PackageDescription qualified as C

+import Distribution.Types.PackageId qualified as C

+import Distribution.Types.PackageName (PackageName)

+import Distribution.Types.PackageName qualified as C

+import Distribution.Types.Version qualified as C

+import Distribution.Utils.ShortText qualified as C

+import System.FilePath

+

+data Contact = Contact { contactName, contactEmail :: T.Text }

+    deriving (Eq, Ord, Show)

+

+parseContact :: T.Text -> Contact

+parseContact t

+  | '<' `T.elem` t =

+    let (name,email) = T.break (== '<') t

+     in Contact (T.strip name) (T.strip $ T.takeWhile (/= '>') $ T.drop 1 email)

+  | otherwise = Contact "" t

+

+contactRecipient :: Contact -> T.Text

+contactRecipient (Contact name email)

+  | T.null name = email

+  | otherwise = name <> " <" <> email <> ">"

+

+data Package = Package { pkgName :: PackageName

+                       , pkgPath :: FilePath

+                       , pkgIsReleaseTag :: String -> Bool

+                       }

+

+getPackageDescription :: Package -> IO C.PackageDescription

+getPackageDescription pkg = do

+    Just gpd <- C.parseGenericPackageDescriptionMaybe <$> BS.readFile (pkgPath pkg </> C.unPackageName (pkgName pkg) <.> "cabal")

+    return $ C.packageDescription gpd

+

+getPackageMaintainers :: Package -> IO [Contact]

+getPackageMaintainers pkg =

+    map (parseContact . T.strip . T.filter (/= '\n')) . T.splitOn ","

+    . T.pack . C.fromShortText . C.maintainer

+    <$> getPackageDescription pkg

+

+getPackageVersion :: Package -> IO Version

+getPackageVersion pkg =

+    Data.Version.makeVersion . C.versionNumbers . C.pkgVersion . C.package

+    <$> getPackageDescription pkg

+

+{-# LANGUAGE OverloadedStrings #-}

+

+module Packages (packages) where

+

+import Package

+import Data.Char (isDigit)

+import qualified Distribution.Types.PackageName as C

+import Data.List

+

+packages :: [Package]

+packages =

+    [ stdPackage "file-io" "libraries/file-io"

+    , stdPackage "hsc2hs" "utils/hsc2hs"

+    , Package "Cabal" "libraries/Cabal/Cabal"  (isPrefixTag "Cabal-")

+    , Package "Cabal-syntax" "libraries/Cabal/Cabal-syntax" (isPrefixTag "Cabal-syntax-")

+    , stdPackage "bytestring" "libraries/bytestring"

+    , stdPackage "binary" "libraries/binary"

+    , stdPackage "array" "libraries/array"

+    , stdPackage "containers" "libraries/containers/containers"

+    , stdPackage "deepseq" "libraries/deepseq"

+    , stdPackage "directory" "libraries/directory"

+    , stdPackage "filepath" "libraries/filepath"

+    , stdPackage "haskeline" "libraries/haskeline"

+    , stdPackage "hpc" "libraries/hpc"

+    , stdPackage "mtl" "libraries/mtl"

+    , stdPackage "parsec" "libraries/parsec"

+    , stdPackage "pretty" "libraries/pretty"

+    , stdPackage "process" "libraries/process"

+    , stdPackage "terminfo" "libraries/terminfo"

+    , stdPackage "text" "libraries/text"

+    , stdPackage "time" "libraries/time"

+    , stdPackage "unix" "libraries/unix"

+    , stdPackage "exceptions" "libraries/exceptions"

+    , stdPackage "semaphore-compat" "libraries/semaphore-compat"

+    , stdPackage "stm" "libraries/stm"

+    , stdPackage "Win32" "libraries/Win32"

+    , stdPackage "xhtml" "libraries/xhtml"

+    ]

+

+stdPackage :: C.PackageName -> FilePath -> Package

+stdPackage name path = Package name path stdIsReleaseTag

+

+looksLikeVersion :: String -> Bool

+looksLikeVersion =

+    all (\c -> isDigit c || c == '.')

+

+isPrefixTag :: String -> String -> Bool

+isPrefixTag prefix tag

+  | Just rest <- prefix `stripPrefix` tag = looksLikeVersion rest

+  | otherwise = False

+

+stdIsReleaseTag :: String -> Bool

+stdIsReleaseTag tag =

+    isPrefixTag "v" tag || isPrefixTag "" tag

+{-# LANGUAGE ImportQualifiedPost #-}

+{-# LANGUAGE OverloadedStrings #-}

+

+module Pretty

+    ( module Prettyprinter

+    , Doc

+    , mkMsg

+    , Severity(..)

+    , severityIcon

+    , bulletList

+    , ppCommit

+    , ppPackage

+    , ppVersion

+    , ppHeading

+    , putDoc

+    ) where

+

+import Data.Version

+import Package

+import Prettyprinter hiding (Doc)

+import Prettyprinter qualified as PP

+import Prettyprinter.Render.Terminal

+import Distribution.Types.PackageName qualified as C

+

+type Doc = PP.Doc AnsiStyle

+

+ppPackage :: Package -> Doc

+ppPackage =

+    annotate (color Green) . pretty . C.unPackageName . pkgName

+

+ppVersion :: Version -> Doc

+ppVersion v =

+    annotate (color Blue) $ pretty $ showVersion v

+

+ppCommit :: Doc -> Doc

+ppCommit =

+    annotate (color Blue)

+

+ppHeading :: Doc -> Doc

+ppHeading =

+    annotate bold . ("#" <+>)

+

+bullet :: Doc

+bullet = "‣"

+

+bulletList :: [Doc] -> Doc

+bulletList xs = vcat [ " " <> bullet <+> align x | x <- xs ]

+

+data Severity = Info | Warning | Error

+

+severityIcon :: Severity -> Doc

+severityIcon Info    = annotate (color Blue) "ℹ" -- "🔵"

+severityIcon Warning = "🟡"

+severityIcon Error   = annotate (color Red) "✗" -- "🔴"

+

+mkMsg :: Severity -> Doc -> Doc

+mkMsg s msg = severityIcon s <+> msg