Ben Gamari pushed to branch wip/boot-lib-testing at Glasgow Haskell Compiler / GHC Commits: ed246211 by Ben Gamari at 2025-06-12T18:44:05-04:00 check-submodules: initial commit - - - - - 5ff1aeba by Ben Gamari at 2025-06-12T18:44:05-04:00 gitlab-ci: Add boot library linting steps - - - - - 15 changed files: - .gitlab-ci.yml - + 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/CheckTags.hs - + utils/check-submodules/src/CheckVersions.hs - + utils/check-submodules/src/Git.hs - + utils/check-submodules/src/Hackage.hs - + utils/check-submodules/src/Package.hs - + utils/check-submodules/src/Packages.hs - + utils/check-submodules/src/Pretty.hs Changes: ===================================== .gitlab-ci.yml ===================================== @@ -205,6 +205,25 @@ not-interruptible: - if: $NIGHTLY when: always +.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 + ############################################################ # Validate jobs @@ -255,6 +274,24 @@ typecheck-testsuite: - mypy testsuite/driver/runtests.py dependencies: [] +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 + # We allow the submodule checker to fail when run on merge requests (to # accommodate, e.g., haddock changes not yet upstream) but not on `master` or # Marge jobs. @@ -292,26 +329,11 @@ lint-author: - *drafts-can-fail-lint lint-ci-config: - image: nixos/nix:2.25.2 - extends: .lint + extends: [.lint, .nix] # We don't need history/submodules in this job variables: GIT_DEPTH: 1 GIT_SUBMODULE_STRATEGY: none - 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 script: - nix run .gitlab/generate-ci#generate-jobs # 1 if .gitlab/generate_jobs changed the output of the generated config ===================================== 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,47 @@ +# check-submodules + +`check-submodules` is a utility automating several common tasks encountered +when check and maintaining GHC's boot library dependencies. It has several +modes. + + +## `check-versions` + +The `check-versions` mode verifies that GHC is up-to-date with each +library's Hackage releases. Specifically, it checks 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 + + +## `check-tags` + +The `check-tags` mode is used to verify that GHC does not differ from the +upstream releases in non-trivial ways. + +Specifically, it compares each submodule's `HEAD` commit against the most +recent predecessor release tag. If there are non-trivial differences (that is, +changes outside of dot-files), then the check fails and emits a summary of the +differing files. + + +## `summarize` + +The `summarize` mode produces a convenient summary of the current submodule +state. + + +## `email` + +The `email` mode produces a correctly-formatted email recipient list containing +the maintainers of all boot libraries. + + +## Usage + +The tool can be readily run via the included nix flake from the root of the GHC +tree: +```bash +nix run ./utils/check-submodules# -- check-versions +``` ===================================== utils/check-submodules/app/Main.hs ===================================== @@ -0,0 +1,15 @@ +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)" ===================================== utils/check-submodules/check-submodules.cabal ===================================== @@ -0,0 +1,50 @@ +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 ===================================== 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/CheckTags.hs ===================================== @@ -0,0 +1,68 @@ +{-# 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" ===================================== utils/check-submodules/src/CheckVersions.hs ===================================== @@ -0,0 +1,83 @@ +{-# 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, sortOn, 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_ (sortOn pkgName 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 + ] + putStrLn "" + exitWith $ if null errs then ExitSuccess else ExitFailure 1 + ===================================== utils/check-submodules/src/Git.hs ===================================== @@ -0,0 +1,52 @@ +{-# 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] + ===================================== 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,62 @@ +{-# 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 + ===================================== utils/check-submodules/src/Packages.hs ===================================== @@ -0,0 +1,56 @@ +{-# 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 = + [ Package "Cabal" "libraries/Cabal/Cabal" (isStdPrefixTag "Cabal-") + , Package "Cabal-syntax" "libraries/Cabal/Cabal-syntax" (isStdPrefixTag "Cabal-syntax-") + , stdPackage "array" "libraries/array" + , stdPackage "binary" "libraries/binary" + , stdPackage "bytestring" "libraries/bytestring" + , stdPackage "containers" "libraries/containers/containers" + , stdPackage "deepseq" "libraries/deepseq" + , stdPackage "directory" "libraries/directory" + , stdPackage "file-io" "libraries/file-io" + , stdPackage "filepath" "libraries/filepath" + , stdPackage "haskeline" "libraries/haskeline" + , stdPackage "hpc" "libraries/hpc" + , stdPackage "hsc2hs" "utils/hsc2hs" + , stdPackage "mtl" "libraries/mtl" + , stdPackage "os-string" "libraries/os-string" + , 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 (isStdPrefixTag "") + +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 + +isStdPrefixTag :: String -> String -> Bool +isStdPrefixTag prefix tag = + isPrefixTag (prefix <> "v") tag || isPrefixTag prefix tag + ===================================== utils/check-submodules/src/Pretty.hs ===================================== @@ -0,0 +1,57 @@ +{-# 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 View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/compare/795105ee383d32e57c93aaf58681842... -- View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/compare/795105ee383d32e57c93aaf58681842... You're receiving this email because of your account on gitlab.haskell.org.