[Git][ghc/ghc][wip/boot-lib-testing] check-submodules: initial commit
Ben Gamari (@bgamari)
gitlab at gitlab.haskell.org
Fri Dec 20 20:09:30 UTC 2024
Ben Gamari pushed to branch wip/boot-lib-testing at Glasgow Haskell Compiler / GHC
Commits:
4f703ff5 by Ben Gamari at 2024-12-20T15:09:20-05:00
check-submodules: initial commit
- - - - -
10 changed files:
- + utils/check-submodules/LICENSE
- + utils/check-submodules/README.mkd
- + utils/check-submodules/app/Main.hs
- + utils/check-submodules/check-submodules.cabal
- + utils/check-submodules/flake.lock
- + utils/check-submodules/flake.nix
- + utils/check-submodules/hie.yaml
- + utils/check-submodules/src/CheckSubmodules.hs
- + utils/check-submodules/src/Hackage.hs
- + utils/check-submodules/src/Package.hs
Changes:
=====================================
utils/check-submodules/LICENSE
=====================================
@@ -0,0 +1,30 @@
+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.
=====================================
utils/check-submodules/README.mkd
=====================================
@@ -0,0 +1,16 @@
+# 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#
+```
=====================================
utils/check-submodules/app/Main.hs
=====================================
@@ -0,0 +1,13 @@
+module Main (main) where
+
+import CheckSubmodules
+import System.Environment (getArgs)
+
+main :: IO ()
+main = do
+ args <- getArgs
+ case args of
+ ["check"] -> check
+ ["summarize"] -> summarize
+ ["email"] -> maintainerEmails >>= putStrLn
+ _ -> fail "invalid mode"
=====================================
utils/check-submodules/check-submodules.cabal
=====================================
@@ -0,0 +1,41 @@
+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 at 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: Hackage, CheckSubmodules, Package
+ build-depends: base,
+ wreq,
+ aeson,
+ bytestring,
+ text,
+ transformers,
+ filepath,
+ microlens,
+ containers,
+ Cabal
+ hs-source-dirs: src
+ default-language: Haskell2010
=====================================
utils/check-submodules/flake.lock
=====================================
@@ -0,0 +1,58 @@
+{
+ "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
+}
=====================================
utils/check-submodules/flake.nix
=====================================
@@ -0,0 +1,26 @@
+{
+ 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;
+ };
+ }
+ );
+}
+
=====================================
utils/check-submodules/hie.yaml
=====================================
@@ -0,0 +1,2 @@
+cradle:
+ cabal:
=====================================
utils/check-submodules/src/CheckSubmodules.hs
=====================================
@@ -0,0 +1,104 @@
+{-# LANGUAGE ImportQualifiedPost #-}
+{-# LANGUAGE OverloadedStrings #-}
+{-# LANGUAGE TupleSections #-}
+
+module CheckSubmodules
+ ( check
+ , summarize
+ , maintainerEmails
+ , packages
+ ) 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 Package
+
+isPvpCompatible :: Version -> Version -> Bool
+isPvpCompatible a b =
+ take 2 (versionBranch a) == take 2 (versionBranch b)
+
+packages :: [Package]
+packages =
+ [ Package "file-io" "libraries/file-io"
+ , Package "hsc2hs" "utils/hsc2hs"
+ , Package "Cabal" "libraries/Cabal/Cabal"
+ , Package "Cabal-syntax" "libraries/Cabal/Cabal-syntax"
+ , Package "bytestring" "libraries/bytestring"
+ , Package "binary" "libraries/binary"
+ , Package "array" "libraries/array"
+ , Package "containers" "libraries/containers/containers"
+ , Package "deepseq" "libraries/deepseq"
+ , Package "directory" "libraries/directory"
+ , Package "filepath" "libraries/filepath"
+ , Package "haskeline" "libraries/haskeline"
+ , Package "hpc" "libraries/hpc"
+ , Package "mtl" "libraries/mtl"
+ , Package "parsec" "libraries/parsec"
+ , Package "pretty" "libraries/pretty"
+ , Package "process" "libraries/process"
+ , Package "terminfo" "libraries/terminfo"
+ , Package "text" "libraries/text"
+ , Package "time" "libraries/time"
+ , Package "unix" "libraries/unix"
+ , Package "exceptions" "libraries/exceptions"
+ , Package "semaphore-compat" "libraries/semaphore-compat"
+ , Package "stm" "libraries/stm"
+ , Package "Win32" "libraries/Win32"
+ , Package "xhtml" "libraries/xhtml"
+ ]
+
+checkPackage :: Package -> WriterT [String] IO ()
+checkPackage pkg = do
+ v <- liftIO $ getPackageVersion pkg
+ available <- liftIO $ getVersions (pkgName pkg)
+
+ case M.lookup v available of
+ Nothing -> tell ["Version not on Hackage"]
+ Just Deprecated -> tell ["Version has been deprecated"]
+ Just Normal -> return ()
+
+ let compatible = [ v'
+ | v' <- M.keys available -- versions available via Hackage...
+ , v' > v -- that are newer than the submodule...
+ , v' `isPvpCompatible` v -- and are compatible with the submodule
+ ]
+ case compatible of
+ [] -> return ()
+ vs -> tell ["At " <> showVersion v <> " but version " <> showVersion (maximum vs) <> " is available"]
+
+ return ()
+
+formatError :: Package -> String -> String
+formatError pkg err =
+ pkgPath pkg <> ": " <> err
+
+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
+
+check :: IO ()
+check = do
+ errs <- mapM (\pkg -> map (pkg, ) <$> execWriterT (checkPackage pkg)) packages
+ mapM_ (putStrLn . uncurry formatError) (concat errs)
+ exitWith $ if null errs then ExitSuccess else ExitFailure 1
+
=====================================
utils/check-submodules/src/Hackage.hs
=====================================
@@ -0,0 +1,32 @@
+{-# 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
+
=====================================
utils/check-submodules/src/Package.hs
=====================================
@@ -0,0 +1,61 @@
+{-# 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
+ }
+
+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
+
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/4f703ff55fe7426340ca3c933ddd949bd6edc1cc
--
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/4f703ff55fe7426340ca3c933ddd949bd6edc1cc
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/20241220/b16d803e/attachment-0001.html>
More information about the ghc-commits
mailing list