diff options
author | Matthew Pickering <matthewtpickering@gmail.com> | 2022-02-18 17:27:32 +0100 |
---|---|---|
committer | Marge Bot <ben+marge-bot@smart-cactus.org> | 2022-02-24 20:25:06 -0500 |
commit | 6555b68ca0678827b89c5624db071f5a485d18b7 (patch) | |
tree | 9dbcd231add48a179d7751606523865029d2fc1a | |
parent | 06c18990fb6f10aaf1907ba8f0fe3f1a138da159 (diff) | |
download | haskell-6555b68ca0678827b89c5624db071f5a485d18b7.tar.gz |
Move linters into the tree
This MR moves the GHC linters into the tree, so that they can be run directly using Hadrian.
* Query all files tracked by Git instead of using changed files, so that we can run the exact same linting step locally and in a merge request.
* Only check that the changelogs don't contain TBA when RELEASE=YES.
* Add hadrian/lint script, which runs all the linting steps.
* Ensure the hlint job exits with a failure if hlint is not installed (otherwise we were ignoring the failure). Given that hlint doesn't seem to be available in CI at the moment, I've temporarily allowed failure in the hlint job.
* Run all linting tests in CI using hadrian.
42 files changed, 1166 insertions, 163 deletions
diff --git a/.gitlab-ci.yml b/.gitlab-ci.yml index 0a2d34db8d..c6d95612a5 100644 --- a/.gitlab-ci.yml +++ b/.gitlab-ci.yml @@ -157,7 +157,7 @@ not-interruptible: stage: not-interruptible script: "true" interruptible: false - image: "registry.gitlab.haskell.org/ghc/ci-images/linters:$DOCKER_REV" + image: "registry.gitlab.haskell.org/ghc/ci-images/x86_64-linux-deb10:$DOCKER_REV" tags: - lint rules: @@ -175,39 +175,24 @@ not-interruptible: ghc-linters: stage: tool-lint - image: "registry.gitlab.haskell.org/ghc/ci-images/linters:$DOCKER_REV" - extends: .lint - script: - - git fetch "$CI_MERGE_REQUEST_PROJECT_URL" $CI_MERGE_REQUEST_TARGET_BRANCH_NAME - - base="$(git merge-base FETCH_HEAD $CI_COMMIT_SHA)" - - "echo Linting changes between $base..$CI_COMMIT_SHA" - # - validate-commit-msg .git $(git rev-list $base..$CI_COMMIT_SHA) - - validate-whitespace .git $(git rev-list $base..$CI_COMMIT_SHA) - - .gitlab/linters/check-makefiles.py commits $base $CI_COMMIT_SHA - - .gitlab/linters/check-cpp.py commits $base $CI_COMMIT_SHA - - .gitlab/linters/check-version-number.sh - - python3 testsuite/tests/linters/checkUniques/check-uniques.py . - dependencies: [] - rules: - - if: $CI_MERGE_REQUEST_ID - - *drafts-can-fail-lint - -lint-notes: - image: "registry.gitlab.haskell.org/ghc/ci-images/linters:$DOCKER_REV" + image: "registry.gitlab.haskell.org/ghc/ci-images/x86_64-linux-deb10:$DOCKER_REV" extends: .lint-params variables: BUILD_FLAVOUR: default script: - .gitlab/ci.sh configure - - .gitlab/ci.sh run_hadrian test --only="notes" + - .gitlab/ci.sh run_hadrian test --test-root-dirs="testsuite/tests/linters" dependencies: [] + rules: + - if: $CI_MERGE_REQUEST_ID + - *drafts-can-fail-lint # Run mypy Python typechecker on linter scripts. lint-linters: image: "registry.gitlab.haskell.org/ghc/ci-images/linters:$DOCKER_REV" extends: .lint script: - - mypy .gitlab/linters/*.py + - mypy testsuite/tests/linters/regex-linters/*.py dependencies: [] # Check that .T files all parse by listing broken tests. @@ -230,14 +215,18 @@ typecheck-testsuite: # accommodate, e.g., haddock changes not yet upstream) but not on `master` or # Marge jobs. .lint-submods: - image: "registry.gitlab.haskell.org/ghc/ci-images/linters:$DOCKER_REV" - extends: .lint + image: "registry.gitlab.haskell.org/ghc/ci-images/x86_64-linux-deb10:$DOCKER_REV" + extends: .lint-params + variables: + BUILD_FLAVOUR: default script: + - .gitlab/ci.sh configure + - .gitlab/ci.sh run_hadrian stage1:exe:lint-submodule-refs - git fetch "$CI_MERGE_REQUEST_PROJECT_URL" $CI_MERGE_REQUEST_TARGET_BRANCH_NAME - base="$(git merge-base FETCH_HEAD $CI_COMMIT_SHA)" - "echo Linting submodule changes between $base..$CI_COMMIT_SHA" - git submodule foreach git remote update - - submodchecker . $(git rev-list $base..$CI_COMMIT_SHA) + - _build/stage0/bin/lint-submodule-refs . $(git rev-list $base..$CI_COMMIT_SHA) dependencies: [] lint-submods: @@ -251,34 +240,55 @@ lint-submods: lint-submods-branch: extends: .lint-submods + variables: + BUILD_FLAVOUR: default script: + - .gitlab/ci.sh configure + - .gitlab/ci.sh run_hadrian stage1:exe:lint-submodule-refs - "echo Linting submodule changes between $CI_COMMIT_BEFORE_SHA..$CI_COMMIT_SHA" - git submodule foreach git remote update - - submodchecker . $(git rev-list $CI_COMMIT_BEFORE_SHA..$CI_COMMIT_SHA) + - _build/stage0/bin/lint-submodule-refs . $(git rev-list $CI_COMMIT_BEFORE_SHA..$CI_COMMIT_SHA) rules: - if: '$CI_COMMIT_BRANCH == "master"' - if: '$CI_COMMIT_BRANCH =~ /ghc-[0.9]+\.[0-9]+/' - *drafts-can-fail-lint -.lint-changelogs: - image: "registry.gitlab.haskell.org/ghc/ci-images/linters:$DOCKER_REV" +############################################################ +# GHC source code linting +############################################################ + +.lint-params: + needs: [] + image: "registry.gitlab.haskell.org/ghc/ci-images/x86_64-linux-deb10:$DOCKER_REV" extends: .lint - dependencies: [] - script: - - bash .gitlab/linters/check-changelogs.sh + before_script: + - export PATH="/opt/toolchain/bin:$PATH" + # workaround for docker permissions + - sudo chown ghc:ghc -R . + - git submodule sync --recursive + - git submodule update --init --recursive + - git checkout .gitmodules + - .gitlab/ci.sh setup + after_script: + - .gitlab/ci.sh save_cache + - cat ci-timings + variables: + GHC_FLAGS: -Werror + cache: + key: lint-$CACHE_REV + paths: + - cabal-cache -lint-changelogs: - extends: .lint-changelogs - # Allow failure since this isn't a final release. +hlint-ghc-and-base: + extends: .lint-params + variables: + BUILD_FLAVOUR: default + script: + - .gitlab/ci.sh setup + - .gitlab/ci.sh configure + - .gitlab/ci.sh run_hadrian lint:base + - .gitlab/ci.sh run_hadrian lint:compiler allow_failure: true - rules: - - if: '$CI_COMMIT_BRANCH =~ /ghc-[0.9]+\.[0-9]+/' - -lint-release-changelogs: - extends: .lint-changelogs - rules: - - if: '$CI_COMMIT_BRANCH =~ /ghc-[0.9]+\.[0-9]+/' - - *drafts-can-fail-lint ############################################################ # Validation via Pipelines (hadrian) @@ -410,42 +420,6 @@ hadrian-ghc-in-ghci: - cabal-cache ############################################################ -# GHC source code linting -############################################################ - -.lint-params: - needs: [] - image: "registry.gitlab.haskell.org/ghc/ci-images/x86_64-linux-deb10:$DOCKER_REV" - extends: .lint - before_script: - - export PATH="/opt/toolchain/bin:$PATH" - # workaround for docker permissions - - sudo chown ghc:ghc -R . - - git submodule sync --recursive - - git submodule update --init --recursive - - git checkout .gitmodules - - .gitlab/ci.sh setup - after_script: - - .gitlab/ci.sh save_cache - - cat ci-timings - variables: - GHC_FLAGS: -Werror - cache: - key: lint-$CACHE_REV - paths: - - cabal-cache - -lint-libs: - extends: .lint-params - variables: - BUILD_FLAVOUR: default - script: - - .gitlab/ci.sh setup - - .gitlab/ci.sh configure - - .gitlab/ci.sh run_hadrian lint:base - - .gitlab/ci.sh run_hadrian lint:compiler - -############################################################ # Validation via Pipelines (make) ############################################################ diff --git a/.gitlab/linters/check-changelogs.sh b/.gitlab/linters/check-changelogs.sh deleted file mode 100755 index 56ac187a90..0000000000 --- a/.gitlab/linters/check-changelogs.sh +++ /dev/null @@ -1,16 +0,0 @@ -#!/usr/bin/env bash - -set -e - -COLOR_RED="\e[31m" -COLOR_GREEN="\e[32m" -COLOR_NONE="\e[0m" - -grep TBA libraries/*/changelog.md && ( - echo -e "${COLOR_RED}Error: Found \"TBA\"s in changelogs.${COLOR_NONE}" - exit 1 -) || ( - echo -e "${COLOR_GREEN}changelogs look okay.${COLOR_NONE}" - exit 0 -) - diff --git a/cabal.project-reinstall b/cabal.project-reinstall index e026e70a5d..aa6fc0c47e 100644 --- a/cabal.project-reinstall +++ b/cabal.project-reinstall @@ -46,6 +46,7 @@ packages: ./compiler ./utils/runghc ./utils/unlit ./utils/iserv + ./linters/**/*.cabal constraints: ghc +internal-interpreter +dynamic-system-linke +terminfo, ghc-bin +internal-interpreter +threaded, @@ -546,13 +546,15 @@ utils/ghc-pkg/dist-install/package-data.mk: $(fixed_pkg_prev) utils/hsc2hs/dist-install/package-data.mk: $(fixed_pkg_prev) utils/compare_sizes/dist-install/package-data.mk: $(fixed_pkg_prev) utils/runghc/dist-install/package-data.mk: $(fixed_pkg_prev) -utils/notes-util/dist-install/package-data.mk: $(fixed_pkg_prev) utils/iserv/stage2/package-data.mk: $(fixed_pkg_prev) utils/iserv/stage2_p/package-data.mk: $(fixed_pkg_prev) utils/iserv/stage2_dyn/package-data.mk: $(fixed_pkg_prev) ifeq "$(Windows_Host)" "YES" utils/gen-dll/dist-install/package-data.mk: $(fixed_pkg_prev) endif +linters/linters-common/dist-install/package-data.mk: $(fixed_pkg_prev) +linters/lint-notes/dist-install/package-data.mk: $(fixed_pkg_prev) linters/linters-common/dist-install/package-data.mk +linters/lint-whitespace/dist-install/package-data.mk: $(fixed_pkg_prev) linters/linters-common/dist-install/package-data.mk # the GHC package doesn't live in libraries/, so we add its dependency manually: compiler/stage2/package-data.mk: $(fixed_pkg_prev) @@ -669,7 +671,6 @@ BUILD_DIRS += utils/hsc2hs BUILD_DIRS += utils/ghc-pkg BUILD_DIRS += utils/testremove BUILD_DIRS += utils/check-ppr -BUILD_DIRS += utils/notes-util BUILD_DIRS += utils/check-exact BUILD_DIRS += utils/count-deps BUILD_DIRS += utils/ghc-cabal @@ -679,6 +680,9 @@ BUILD_DIRS += ghc BUILD_DIRS += docs/users_guide BUILD_DIRS += utils/compare_sizes BUILD_DIRS += utils/iserv +BUILD_DIRS += linters/linters-common +BUILD_DIRS += linters/lint-notes +BUILD_DIRS += linters/lint-whitespace # ---------------------------------------------- # Actually include the sub-ghc.mk's @@ -1092,7 +1096,7 @@ BIN_DIST_MK = $(BIN_DIST_PREP_DIR)/bindist.mk unix-binary-dist-prep: $(includes_dist-install_H_FILES_GENERATED) $(call removeTrees,bindistprep/) "$(MKDIRHIER)" $(BIN_DIST_PREP_DIR) - set -e; for i in packages LICENSE compiler ghc rts libraries utils docs libffi includes driver mk rules Makefile m4 aclocal.m4 config.sub config.guess install-sh llvm-targets llvm-passes ghc.mk inplace distrib/configure.ac distrib/README distrib/INSTALL; do ln -s ../../$$i $(BIN_DIST_PREP_DIR)/; done + set -e; for i in packages LICENSE compiler ghc rts libraries linters utils docs libffi includes driver mk rules Makefile m4 aclocal.m4 config.sub config.guess install-sh llvm-targets llvm-passes ghc.mk inplace distrib/configure.ac distrib/README distrib/INSTALL; do ln -s ../../$$i $(BIN_DIST_PREP_DIR)/; done echo "HADDOCK_DOCS = $(HADDOCK_DOCS)" >> $(BIN_DIST_MK) echo "BUILD_SPHINX_HTML = $(BUILD_SPHINX_HTML)" >> $(BIN_DIST_MK) echo "BUILD_SPHINX_PDF = $(BUILD_SPHINX_PDF)" >> $(BIN_DIST_MK) diff --git a/hadrian/lint b/hadrian/lint new file mode 100644 index 0000000000..8c43c89bd1 --- /dev/null +++ b/hadrian/lint @@ -0,0 +1,5 @@ +#!/usr/bin/env bash + +"hadrian/build" "$@" test --test-root-dirs="testsuite/tests/linters" + # hlint targets disabled as they do not currently run on CI. + # lint:compiler lint:base diff --git a/hadrian/src/Packages.hs b/hadrian/src/Packages.hs index a44e3cd95e..9ca18f14c3 100644 --- a/hadrian/src/Packages.hs +++ b/hadrian/src/Packages.hs @@ -9,7 +9,9 @@ module Packages ( hsc2hs, hp2ps, hpc, hpcBin, integerGmp, integerSimple, iserv, iservProxy, libffi, libiserv, mtl, parsec, pretty, primitive, process, remoteIserv, rts, runGhc, stm, templateHaskell, terminfo, text, time, timeout, touchy, - transformers, unlit, unix, win32, xhtml, noteLinter, ghcPackages, isGhcPackage, + transformers, unlit, unix, win32, xhtml, + lintersCommon, lintNotes, lintCommitMsg, lintSubmoduleRefs, lintWhitespace, + ghcPackages, isGhcPackage, -- * Package information programName, nonHsMainPackage, autogenPath, programPath, timeoutPath, @@ -39,13 +41,25 @@ ghcPackages = , hp2ps, hpc, hpcBin, integerGmp, integerSimple, iserv, libffi, libiserv, mtl , parsec, pretty, process, rts, runGhc, stm, templateHaskell , terminfo, text, time, touchy, transformers, unlit, unix, win32, xhtml - , timeout, noteLinter ] + , timeout + , lintersCommon + , lintNotes, lintCommitMsg, lintSubmoduleRefs, lintWhitespace ] -- TODO: Optimise by switching to sets of packages. isGhcPackage :: Package -> Bool isGhcPackage = (`elem` ghcPackages) -- | Package definitions, see 'Package'. +array, base, binary, bytestring, cabalSyntax, cabal, checkPpr, checkExact, countDeps, + compareSizes, compiler, containers, deepseq, deriveConstants, directory, + exceptions, filepath, genapply, genprimopcode, ghc, ghcBignum, ghcBoot, ghcBootTh, + ghcCompact, ghcHeap, ghci, ghciWrapper, ghcPkg, ghcPrim, haddock, haskeline, hsc2hs, + hp2ps, hpc, hpcBin, integerGmp, integerSimple, iserv, iservProxy, remoteIserv, libffi, libiserv, mtl, + parsec, pretty, primitive, process, rts, runGhc, stm, templateHaskell, + terminfo, text, time, touchy, transformers, unlit, unix, win32, xhtml, + timeout, + lintersCommon, lintNotes, lintCommitMsg, lintSubmoduleRefs, lintWhitespace + :: Package array = lib "array" base = lib "base" binary = lib "binary" @@ -108,7 +122,12 @@ unlit = util "unlit" unix = lib "unix" win32 = lib "Win32" xhtml = lib "xhtml" -noteLinter = prg "notes-util" `setPath` "utils/notes-util" + +lintersCommon = lib "linters-common" `setPath` "linters/linters-common" +lintNotes = linter "lint-notes" +lintCommitMsg = linter "lint-commit-msg" +lintSubmoduleRefs = linter "lint-submodule-refs" +lintWhitespace = linter "lint-whitespace" -- | Construct a library package, e.g. @array@. lib :: PackageName -> Package @@ -126,6 +145,10 @@ prg name = program name name util :: PackageName -> Package util name = program name ("utils" -/- name) +-- | Construct a linter executable program (lives in the \"linters\" subdirectory). +linter :: PackageName -> Package +linter name = program name ("linters" -/- name) + -- | Amend a package path if it doesn't conform to a typical pattern. setPath :: Package -> FilePath -> Package setPath pkg path = pkg { pkgPath = path } diff --git a/hadrian/src/Rules/Docspec.hs b/hadrian/src/Rules/Docspec.hs index 69b49a1cc5..30f6a039eb 100644 --- a/hadrian/src/Rules/Docspec.hs +++ b/hadrian/src/Rules/Docspec.hs @@ -8,6 +8,7 @@ import Base import Context.Path import Settings.Builders.Common import qualified Packages as P +import System.Exit (exitFailure) docspecRules :: Rules () docspecRules = do @@ -21,8 +22,9 @@ docspec lintAction = do putBuild "| Running cabal-docspec…" lintAction putSuccess "| Done." - else + else do putFailure "| Please make sure you have the `cabal-docspec` executable in your $PATH" + liftIO exitFailure base :: Action () base = do diff --git a/hadrian/src/Rules/Lint.hs b/hadrian/src/Rules/Lint.hs index bb7df1687a..58f9715f21 100644 --- a/hadrian/src/Rules/Lint.hs +++ b/hadrian/src/Rules/Lint.hs @@ -5,6 +5,7 @@ module Rules.Lint import Base import Settings.Builders.Common import System.Directory (findExecutable) +import System.Exit (exitFailure) lintRules :: Rules () lintRules = do @@ -19,8 +20,9 @@ lint lintAction = do putBuild "| Running the linter…" lintAction putSuccess "| Done." - else + else do putFailure "| Please make sure you have the `hlint` executable in your $PATH" + liftIO exitFailure runHLint :: [FilePath] -- ^ include directories -> [String] -- ^ CPP defines diff --git a/hadrian/src/Rules/Test.hs b/hadrian/src/Rules/Test.hs index fe0aba04cc..4b0ba4a913 100644 --- a/hadrian/src/Rules/Test.hs +++ b/hadrian/src/Rules/Test.hs @@ -44,17 +44,24 @@ countDepsExtra :: Maybe String countDepsExtra = Just "-iutils/count-deps" noteLinterProgPath, noteLinterSourcePath :: FilePath -noteLinterProgPath = "test/bin/notes-util" <.> exe -noteLinterSourcePath = "utils/notes-util/Main.hs" +noteLinterProgPath = "test/bin/lint-notes" <.> exe +noteLinterSourcePath = "linters/lint-notes/Main.hs" noteLinterExtra :: Maybe String -noteLinterExtra = Just "-iutils/notes-util" +noteLinterExtra = Just "-ilinters/lint-notes" + +whitespaceLinterProgPath, whitespaceLinterSourcePath :: FilePath +whitespaceLinterProgPath = "test/bin/lint-whitespace" <.> exe +whitespaceLinterSourcePath = "linters/lint-whitespace/Main.hs" +whitespaceLinterExtra :: Maybe String +whitespaceLinterExtra = Just "-ilinters/lint-whitespace" checkPrograms :: [(String,FilePath, FilePath, Maybe String, Package, Stage -> Stage)] checkPrograms = [ ("test:check-ppr",checkPprProgPath, checkPprSourcePath, checkPprExtra, checkPpr, id) , ("test:check-exact",checkExactProgPath, checkExactSourcePath, checkExactExtra, checkExact, id) , ("test:count-deps",countDepsProgPath, countDepsSourcePath, countDepsExtra, countDeps, id) - , ("lint:notes-util", noteLinterProgPath, noteLinterSourcePath, noteLinterExtra, noteLinter, const Stage0) + , ("lint:notes", noteLinterProgPath, noteLinterSourcePath, noteLinterExtra, lintNotes, const Stage0) + , ("lint:whitespace", whitespaceLinterProgPath, whitespaceLinterSourcePath, whitespaceLinterExtra, lintWhitespace, const Stage0) ] inTreeOutTree :: (Stage -> Action b) -> Action b -> Action b @@ -213,7 +220,8 @@ testRules = do setEnv "CHECK_PPR" (top -/- root -/- checkPprProgPath) setEnv "CHECK_EXACT" (top -/- root -/- checkExactProgPath) setEnv "COUNT_DEPS" (top -/- root -/- countDepsProgPath) - setEnv "NOTES_UTIL" (top -/- root -/- noteLinterProgPath) + setEnv "LINT_NOTES" (top -/- root -/- noteLinterProgPath) + setEnv "LINT_WHITESPACE" (top -/- root -/- whitespaceLinterProgPath) -- This lets us bypass the need to generate a config -- through Make, which happens in testsuite/mk/boilerplate.mk diff --git a/hadrian/src/Settings/Default.hs b/hadrian/src/Settings/Default.hs index 8c490347b9..21ab008cb7 100644 --- a/hadrian/src/Settings/Default.hs +++ b/hadrian/src/Settings/Default.hs @@ -87,7 +87,11 @@ stage0Packages = do , text , transformers , unlit - , noteLinter + , lintersCommon + , lintNotes + , lintCommitMsg + , lintSubmoduleRefs + , lintWhitespace ] ++ [ terminfo | not windowsHost, not cross ] ++ [ timeout | windowsHost ] diff --git a/libraries/base/changelog.md b/libraries/base/changelog.md index 44ac94c32b..a905e2d2f3 100644 --- a/libraries/base/changelog.md +++ b/libraries/base/changelog.md @@ -111,7 +111,7 @@ - `oneBits :: FiniteBits a => a`, `oneBits = complement zeroBits`. -## 4.15.0.0 *TBA* +## 4.15.0.0 *Feb 2021* * `openFile` now calls the `open` system call with an `interruptible` FFI call, ensuring that the call can be interrupted with `SIGINT` on POSIX diff --git a/linters/lint-commit-msg/Main.hs b/linters/lint-commit-msg/Main.hs new file mode 100644 index 0000000000..cf12b19ba5 --- /dev/null +++ b/linters/lint-commit-msg/Main.hs @@ -0,0 +1,160 @@ +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE LambdaCase #-} +{-# LANGUAGE MultiWayIf #-} +{-# LANGUAGE OverloadedStrings #-} + +{-# OPTIONS_GHC -Wno-missing-local-signatures #-} + +module Main where + +-- base +import Control.Monad + ( forM, forM_, unless, when ) +import Data.Maybe + ( isJust ) +import System.Environment + ( getArgs ) +import System.Exit + ( ExitCode(..), exitWith ) + +-- mtl +import Control.Monad.Writer + ( liftIO, execWriter, tell ) + +-- text +import Data.Text + ( Text ) +import qualified Data.Text as T +import qualified Data.Text.IO as T + ( putStrLn ) + +-- linters-common +import Linters.Common + ( LintMsg(..), LintLvl(..) + , gitCatCommit, gitNormCid, tshow + ) + +-------------------------------------------------------------------------------- + +main :: IO () +main = do + dir:refs <- getArgs >>= \case + [] -> fail "usage: lint-commit-msg <git-repo> [<commit-id>+]" + x -> return x + + stats <- forM (map T.pack refs) $ \ref -> do + cid <- gitNormCid dir ref + (_, msg) <- gitCatCommit dir cid + + let cmsgs = lintMsg msg + + liftIO $ do + -- putStrLn (T.unpack cid) + -- forM_ (zip [1::Int ..] (T.lines msg)) $ \(lno,l) -> do + -- putStrLn (show lno <> "\t" <> show l) + -- putStrLn "--" + + let status = maximum (Nothing : [ Just lvl | LintMsg lvl _ _ _ <- cmsgs ]) + ok = status < Just LintLvlErr + + unless (null cmsgs) $ do + putStrLn "=====================================================================================" + putStrLn ("commit " <> T.unpack cid <> " has linter issues:") + putStrLn "" + forM_ cmsgs $ \(LintMsg lvl lno l m) -> do + let lvls = case lvl of + LintLvlErr -> "*ERROR*" + LintLvlWarn -> "Warning" + putStrLn (" " <> lvls <> " on line " <> show lno <> ": " <> T.unpack m) + putStrLn (" > " <> show l) + putStrLn "" + return () + + unless ok $ + putStrLn ("Validation FAILED for " <> T.unpack cid) + + return status + + unless (null $ filter isJust stats) $ + T.putStrLn "=====================================================================================" + + let stats1 = maximum (Nothing : stats) + + unless (stats1 == Nothing) $ do + T.putStrLn "There were commit message linter issues! For more information see" + T.putStrLn " http://tbaggery.com/2008/04/19/a-note-about-git-commit-messages.html" + T.putStrLn "" + + unless (stats1 < Just LintLvlErr) $ do + T.putStrLn "Validation FAILED because at least one commit had linter errors!" + exitWith (ExitFailure 1) + + T.putStrLn "Commit message validation passed!" + +-- | Commit message linter +lintMsg :: Text -> [LintMsg] +lintMsg msg0 = execWriter $ do + -- subject-line validations + if | T.null (T.strip subj) -> errSubj "empty subject line" + | otherwise -> do + when (T.stripStart subj /= subj) $ + errSubj "subject line with leading whitespace" + + when (T.stripEnd subj /= subj) $ + warnSubj "subject line with trailing whitespace" + + when (T.any (== '\t') subj) $ + errSubj "subject line contains TAB" + + if | slen > 80 -> errSubj ("subject line longer than 80 characters (was " <> tshow slen <> " characters)" + <> " -- , ideally subject line is at most 50 characters long") + | slen > 50 -> warnSubj ("subject line longer than 50 characters (was " <> tshow slen <> " characters)") + | slen < 8 -> errSubj ("subject line shorter than 8 characters (was " <> tshow slen <> " characters)") + | otherwise -> return () + + -- 2nd-line & body validations + case lns of + [] -> return () -- empty commit msg -- will have caused already an LintLvlErr + [_] -> return () -- single-line commit msg + (_:line2:body) -> do + -- 2nd line validations + if | not (T.null line2) + -> tell [LintMsg LintLvlErr 2 line2 "2nd line must be empty"] + | null body + -> tell [LintMsg LintLvlWarn 2 line2 "2nd line exists, but no commit msg body found"] + | otherwise -> return () + + -- body validations + forM_ (zip [3..] body) $ \(lineno,l) -> do + let llen = T.length l + warnBody m = tell [LintMsg LintLvlWarn lineno l m] + errBody m = tell [LintMsg LintLvlErr lineno l m] + + when (T.stripEnd l /= l) $ warnBody "trailing whitespace" + + when (T.any (== '\t') l) $ warnBody "contains TAB character" + + when (T.isPrefixOf "Summary:" l) $ + warnBody "redundant Phabricator 'Summary:' tag detected -- please trim your commit message" + + when (T.isPrefixOf "Summary: Signed-off-by:" l) $ + errBody "'Signed-Off-by:'-marker not starting on first column" + + if | llen > 100 -> errBody ("body line longer than 100 characters (was " + <> tshow llen <> " characters) -- " + <> "ideally body lines are at most 72 characters long") + | llen > 72 -> warnBody ("body line longer than 72 characters (was " + <> tshow llen <> " characters)") + | otherwise -> return () + + return () + where + warnSubj m = tell [LintMsg LintLvlWarn 1 subj m] + errSubj m = tell [LintMsg LintLvlErr 1 subj m] + + lns = T.lines msg0 + + subj | (l0:_) <- lns = l0 + | otherwise = "" + + slen = T.length subj diff --git a/linters/lint-commit-msg/cabal.project b/linters/lint-commit-msg/cabal.project new file mode 100644 index 0000000000..444b636706 --- /dev/null +++ b/linters/lint-commit-msg/cabal.project @@ -0,0 +1,2 @@ +packages: ., + ../linters-common diff --git a/linters/lint-commit-msg/lint-commit-msg.cabal b/linters/lint-commit-msg/lint-commit-msg.cabal new file mode 100644 index 0000000000..8020a925a4 --- /dev/null +++ b/linters/lint-commit-msg/lint-commit-msg.cabal @@ -0,0 +1,29 @@ +cabal-version: 3.0 +name: lint-commit-msg +version: 0.1.0.0 +synopsis: Lint a commit message +license: GPL-3.0-only +author: The GHC team +build-type: Simple + +executable lint-commit-msg + ghc-options: + -Wall + + default-language: + Haskell2010 + + hs-source-dirs: + . + + main-is: + Main.hs + + build-depends: + linters-common, + mtl + >=2.1 && <2.3, + base + >= 4.14 && < 5, + text + >= 1.2 && < 2.1 diff --git a/utils/notes-util/Main.hs b/linters/lint-notes/Main.hs index aa9386bc01..02ee3f11d4 100644 --- a/utils/notes-util/Main.hs +++ b/linters/lint-notes/Main.hs @@ -8,9 +8,9 @@ usage :: IO a usage = do putStrLn $ unlines [ "usage:" - , " ghc-notes <mode>" - , " ghc-notes <mode> @<response-file>" - , " ghc-notes <mode> <file>" + , " lint-notes <mode>" + , " lint-notes <mode> @<response-file>" + , " lint-notes <mode> <file>" , "" , "valid modes:" , " dump dump all Note definitions and references" @@ -51,7 +51,7 @@ main = do [mode] -> do let excludeList = [ "testsuite/tests/linters/notes.stdout" - , "utils/notes-util/test" ] + , "linters/lint-notes/test" ] files <- lines <$> readProcess "git" ["ls-tree", "--name-only", "-r", "HEAD"] "" return (parseMode mode, filter (`notElem` excludeList) files) _ -> usage diff --git a/utils/notes-util/Makefile b/linters/lint-notes/Makefile index 176527a3c7..71500f0147 100644 --- a/utils/notes-util/Makefile +++ b/linters/lint-notes/Makefile @@ -10,7 +10,7 @@ # # ----------------------------------------------------------------------------- -dir = utils/notes-util +dir = linters/lint-notes TOP = ../.. include $(TOP)/mk/sub-makefile.mk diff --git a/utils/notes-util/Notes.hs b/linters/lint-notes/Notes.hs index cf267d8d67..cf267d8d67 100644 --- a/utils/notes-util/Notes.hs +++ b/linters/lint-notes/Notes.hs diff --git a/utils/notes-util/check.sh b/linters/lint-notes/check.sh index acac923471..cd87900f9b 100755..100644 --- a/utils/notes-util/check.sh +++ b/linters/lint-notes/check.sh @@ -7,20 +7,20 @@ GHC="${GHC:-ghc}" cd "$(dirname $0)" "$CABAL_INSTALL" build -w "$GHC" -bin="$("$CABAL_INSTALL" list-bin -w "$GHC" ghc-notes)" +bin="$("$CABAL_INSTALL" list-bin -w "$GHC" lint-notes)" cd "$(git rev-parse --show-toplevel)" "$bin" broken-refs \ - | grep -v "utils/notes-util/expected-broken-note-refs:" \ + | grep -v "linters/lint-notes/expected-broken-note-refs:" \ | sed 's/:[0-9]\+:[0-9]\+:/:/' \ > broken-note-refs -if diff -q utils/notes-util/expected-broken-note-refs broken-note-refs; then +if diff -q linters/lint-notes/expected-broken-note-refs broken-note-refs; then printf "No unexpected broken note references" else printf "Found unexpected broken note references:\n\n" - diff -u utils/notes-util/expected-broken-note-refs broken-note-refs || true + diff -u linters/lint-notes/expected-broken-note-refs broken-note-refs || true if [[ "$1" == "-a" ]]; then - cp broken-note-refs utils/notes-util/expected-broken-note-refs + cp broken-note-refs linters/lint-notes/expected-broken-note-refs printf "\n" printf "Accepted new broken note references." else diff --git a/linters/lint-notes/ghc.mk b/linters/lint-notes/ghc.mk new file mode 100644 index 0000000000..bd4e97a85f --- /dev/null +++ b/linters/lint-notes/ghc.mk @@ -0,0 +1,18 @@ +# ----------------------------------------------------------------------------- +# +# (c) 2009 The University of Glasgow +# +# This file is part of the GHC build system. +# +# To understand how the build system works and how to modify it, see +# https://gitlab.haskell.org/ghc/ghc/wikis/building/architecture +# https://gitlab.haskell.org/ghc/ghc/wikis/building/modifying +# +# ----------------------------------------------------------------------------- + +linters/lint-notes_USES_CABAL = YES +linters/lint-notes_PACKAGE = lint-notes +linters/lint-notes_dist-install_PROGNAME = lint-notes +linters/lint-notes_dist-install_INSTALL = NO +linters/lint-notes_dist-install_INSTALL_INPLACE = YES +$(eval $(call build-prog,linters/lint-notes,dist-install,1)) diff --git a/utils/notes-util/notes-util.cabal b/linters/lint-notes/lint-notes.cabal index 41b1a5afdd..9896e74766 100644 --- a/utils/notes-util/notes-util.cabal +++ b/linters/lint-notes/lint-notes.cabal @@ -1,5 +1,5 @@ cabal-version: 2.4 -name: notes-util +name: lint-notes version: 0.1.0.0 synopsis: A tool for querying and checking GHC Notes bug-reports: https://gitlab.haskell.org/ghc/ghc @@ -8,7 +8,7 @@ author: Ben Gamari maintainer: ben@smart-cactus.org copyright: (c) 2022 Ben Gamari -executable notes-util +executable lint-notes main-is: Main.hs other-modules: Notes build-depends: base >= 4 && < 5 , diff --git a/utils/notes-util/test b/linters/lint-notes/test index 3eb1e0466e..3eb1e0466e 100644 --- a/utils/notes-util/test +++ b/linters/lint-notes/test diff --git a/linters/lint-submodule-refs/Main.hs b/linters/lint-submodule-refs/Main.hs new file mode 100644 index 0000000000..f99f066da0 --- /dev/null +++ b/linters/lint-submodule-refs/Main.hs @@ -0,0 +1,77 @@ +{-# LANGUAGE LambdaCase #-} +{-# LANGUAGE OverloadedStrings #-} + +module Main where + +-- base +import Control.Monad + ( forM, forM_, unless, when ) +import Data.List + ( partition ) +import Data.Maybe + ( mapMaybe ) +import System.Environment + ( getArgs ) +import System.Exit + ( ExitCode(..), exitWith ) + +-- text +import qualified Data.Text as T +import qualified Data.Text.IO as T + ( putStrLn ) + +-- linters-common +import Linters.Common + ( GitType(..) + , gitBranchesContain, gitCatCommit, gitDiffTree, gitNormCid + ) + +-------------------------------------------------------------------------------- + +main :: IO () +main = do + dir:refs <- getArgs >>= \case + [] -> fail "usage: lint-submodule-refs <git-repo> [<commit-id>+]" + x -> return x + + forM_ (map T.pack refs) $ \ref -> do + (cid,deltas) <- gitDiffTree dir ref + + let smDeltas = [ (smPath, smCid) | (_, (GitTypeGitLink, smCid), smPath) <- deltas ] + + unless (null smDeltas) $ do + T.putStrLn $ "Submodule update(s) detected in " <> cid <> ":" + + (_, msg) <- gitCatCommit dir cid + + unless ("submodule" `T.isInfixOf` msg) $ do + T.putStrLn "*FAIL* commit message does not contain magic 'submodule' word." + T.putStrLn "This lint avoids accidental changes to git submodules." + T.putStrLn "Include the word 'submodule' in your commit message to silence this warning, e.g. 'Update submodule'." + exitWith (ExitFailure 1) + + bad <- fmap or $ forM smDeltas $ \(smPath,smCid) -> do + T.putStrLn $ " - " <> smPath <> " => " <> smCid + + let smAbsPath = dir ++ "/" ++ T.unpack smPath + remoteBranches <- gitBranchesContain 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 + T.putStrLn $ " *FAIL* commit not found in submodule repo" + T.putStrLn " or not reachable from persistent branches" + T.putStrLn "" + when (not $ null wip) $ do + T.putStrLn " Found the following non-mirrored WIP branches:" + forM_ wip $ \branch -> do + commit <- gitNormCid smAbsPath branch + T.putStrLn $ " - " <> branch <> " -> " <> commit + T.putStrLn "" + pure bad + + if bad + then exitWith (ExitFailure 1) + else T.putStrLn " OK" diff --git a/linters/lint-submodule-refs/cabal.project b/linters/lint-submodule-refs/cabal.project new file mode 100644 index 0000000000..444b636706 --- /dev/null +++ b/linters/lint-submodule-refs/cabal.project @@ -0,0 +1,2 @@ +packages: ., + ../linters-common diff --git a/linters/lint-submodule-refs/lint-submodule-refs.cabal b/linters/lint-submodule-refs/lint-submodule-refs.cabal new file mode 100644 index 0000000000..ce4012adfc --- /dev/null +++ b/linters/lint-submodule-refs/lint-submodule-refs.cabal @@ -0,0 +1,28 @@ +cabal-version: 3.0 +name: lint-submodule-refs +version: 0.1.0.0 +synopsis: Lint submodule references +license: GPL-3.0-only +author: The GHC team +build-type: Simple + +executable lint-submodule-refs + + default-language: + Haskell2010 + + build-depends: + base + >= 4.14 && < 5, + text + >= 1.2 && < 2.1, + linters-common + + ghc-options: + -Wall + + hs-source-dirs: + . + + main-is: + Main.hs diff --git a/linters/lint-whitespace/Main.hs b/linters/lint-whitespace/Main.hs new file mode 100644 index 0000000000..f1657c4f40 --- /dev/null +++ b/linters/lint-whitespace/Main.hs @@ -0,0 +1,265 @@ +{-# LANGUAGE DerivingStrategies #-} +{-# LANGUAGE LambdaCase #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE ViewPatterns #-} + + +module Main where + +-- base +import Control.Exception + ( IOException, handle ) +import Control.Monad + ( forM, forM_, unless, when ) +import Data.Maybe + ( isJust, mapMaybe ) +import System.Environment + ( getArgs ) +import System.Exit + ( ExitCode(..), exitWith ) + +-- containers +import Data.Map.Strict + ( Map ) +import qualified Data.Map.Strict as Map + ( alter, empty, keys, findWithDefault ) + +-- mtl +import Control.Monad.Writer + ( liftIO, execWriter, tell ) + +-- process +import System.Process + ( readProcess ) + +-- text +import Data.Text + ( Text ) +import qualified Data.Text as T +import qualified Data.Text.IO as T + ( readFile ) + +-- linters-common +import Linters.Common + ( LintMsg(..), LintLvl(..) + , GitType(..) + , gitCatBlob, gitDiffTree + , z40 + ) + +-------------------------------------------------------------------------------- + +main :: IO () +main = do + getArgs >>= \case + ("commits":dir:refs) -> mainCommits dir refs + ("commits":_) -> fail "usage: lint-whitespace commits <git-repo> [<commit-id>+]" + ("files":fs) -> mainFiles fs + ("tracked":args) -> mainTracked args + _ -> fail "usage: lint-whitespace <files|commits|tracked> ..." + +mainCommits :: FilePath -> [String] -> IO () +mainCommits dir refs = do + + stats <- forM (map T.pack refs) $ \ref -> do + (cid,deltas) <- gitDiffTree dir ref + + lintMsgs0 <- forM deltas $ \(origs, (gt, blobId), fname) -> if (gt == GitTypeRegFile && hasSuffix fname) + then do + let blobIds0 = [ b0 | (GitTypeRegFile, b0, _) <- origs, b0 /= z40 ] + blob1 <- gitCatBlob dir blobId + blobs0 <- mapM (gitCatBlob dir) blobIds0 + + -- blobs0 will be empty in case in case of newly added files as well as renames/copies + -- blobs0 will contain more than one entry for merge-commits + + return [ (fname, msg) | msg <- lintBlob blobs0 blob1 ] + else return [] + + checkLintMsgs ("commit " <> T.unpack cid) lintMsgs0 + + finalReport stats + +finalReport :: [Maybe LintLvl] -> IO () +finalReport stats = do + unless (null $ filter isJust stats) $ + putStrLn "=====================================================================================" + + let stats1 = maximum (Nothing : stats) + + -- unless (stats1 == Nothing) $ do + -- putStrLn "There were commit message linter issues! For more information see" + -- putStrLn "" + + unless (stats1 < Just LintLvlErr) $ do + putStrLn "Validation FAILED because at least one commit had linter errors!" + exitWith (ExitFailure 1) + + putStrLn "whitespace validation passed!" + +checkLintMsgs :: String -> [[(Text, LintMsg)]] -> IO (Maybe LintLvl) +checkLintMsgs herald lintMsgs0 = do + let lintMsgs = concat lintMsgs0 + status = maximum (Nothing : [ Just lvl | (_, LintMsg lvl _ _ _) <- lintMsgs ]) + ok = status < Just LintLvlErr + + unless (null lintMsgs) $ liftIO $ do + putStrLn "=====================================================================================" + putStrLn (herald <> " has whitespace linter issues:") + putStrLn "" + forM_ lintMsgs $ \(fn, LintMsg lvl lno l m) -> do + let lvls = case lvl of + LintLvlErr -> "*ERROR*" + LintLvlWarn -> "Warning" + putStrLn (" " <> lvls <> " " <> T.unpack fn <> ":" <> show lno <> ": " <> T.unpack m) + putStrLn (" > " <> show l) + putStrLn "" + return () + + unless ok $ liftIO $ + putStrLn ("Validation FAILED for " <> herald) + + return status + +mainFiles :: [FilePath] -> IO () +mainFiles fs = do + stats <- forM fs $ \f -> do + lintMsgs0 <- handle (\(_ :: IOException) -> return []) (lintFile <$> T.readFile f) + checkLintMsgs ("file " <> f) [[(T.pack f, err) | err <- lintMsgs0 ]] + finalReport stats + +mainTracked :: [String] -> IO () +mainTracked args = do + (ignoredFiles, ignoredDirs) <- parseTrackedArgs args + allFiles <- lines <$> readProcess "git" ["ls-tree", "--name-only", "-r", "HEAD"] "" + let files = filter (isTracked ignoredFiles ignoredDirs) allFiles + mainFiles files + +-- Check a file for trailing whitespace and tabs +lintFile :: Text -> [LintMsg] +lintFile blob1 = execWriter $ do + when (hasTabs blob1) $ do + tell [ LintMsg LintLvlErr lno l "introduces TAB" + | (lno,l) <- zip [1..] lns + , "\t" `T.isInfixOf` l + ] + + when (hasTrail blob1) $ do + tell [ LintMsg LintLvlErr lno l "introduces trailing whitespace" + | (lno,l) <- zip [1..] lns, hasTrail l ] + where + lns = T.lines blob1 + +lintBlob :: [Text] -> Text -> [LintMsg] +lintBlob blobs0 blob1 = execWriter $ do + -- Perform simple invariant-preservation checks + when (hasTabs blob1 && not (any hasTabs blobs0)) $ do + tell [ LintMsg LintLvlErr lno l "introduces TAB" + | (lno,l) <- zip [1..] lns + , "\t" `T.isInfixOf` l + ] + + when (hasTrail blob1 && not (any hasTrail blobs0)) $ do + tell [ LintMsg LintLvlErr lno l "introduces trailing whitespace" + | (lno,l) <- zip [1..] lns, hasTrail l ] + + when (missingFinalEOL blob1) $ if not (any missingFinalEOL blobs0) + then tell [LintMsg LintLvlErr llno lln "lacking final EOL"] + else tell [LintMsg LintLvlWarn llno lln "lacking final EOL"] + + where + lns = T.lines blob1 + llno = length lns + lln = case lns of + [] -> "" + _ -> last lns + +hasTabs :: Text -> Bool +hasTabs = T.any (=='\t') + +hasTrail :: Text -> Bool +hasTrail t = or [ " \n" `T.isInfixOf` t + , " \r\n" `T.isInfixOf` t + , "\t\r\n" `T.isInfixOf` t + , " " `T.isSuffixOf` t + , "\t" `T.isSuffixOf` t + ] + +missingFinalEOL :: Text -> Bool +missingFinalEOL = not . T.isSuffixOf "\n" + +-------------------------------------------------- + +data Flag + = IgnoreFiles + | IgnoreDirs + | UnknownFlag Text + deriving stock ( Eq, Ord, Show ) + +parseTrackedArgs :: [String] -> IO ([Text], [Text]) +parseTrackedArgs args = do + unless (null bareArgs) $ + fail "usage: lint-whitespace tracked --ignore-files ... --ignore-dirs ..." + unless (null unknownFlags) $ + fail $ "lint-whitespace tracked: unknown flags " ++ show unknownFlags ++ "\n\ + \supported flags are --ignore-files and --ignore-dirs" + return (ignoredFiles, ignoredDirs) + where + (bareArgs, flagArgs) = splitOn flagMaybe (map T.pack args) + ignoredFiles = Map.findWithDefault [] IgnoreFiles flagArgs + ignoredDirs = Map.findWithDefault [] IgnoreDirs flagArgs + unknownFlags = mapMaybe (\case { UnknownFlag unk -> Just unk ; _ -> Nothing}) + $ Map.keys flagArgs + +-- Assumes the input string has no whitespace. +flagMaybe :: Text -> Maybe Flag +flagMaybe "-f" = Just IgnoreFiles +flagMaybe "--ignore-files" = Just IgnoreFiles +flagMaybe "-d" = Just IgnoreDirs +flagMaybe "--ignore-dirs" = Just IgnoreDirs +flagMaybe str + | let (hyphens, rest) = T.span ((==) '-') str + , not (T.null hyphens) + = Just (UnknownFlag rest) + | otherwise + = Nothing + +splitOn :: forall a b. Ord b => (a -> Maybe b) -> [a] -> ([a], Map b [a]) +splitOn f = go Nothing + where + go :: Maybe b -> [a] -> ([a], Map b [a]) + go _ [] = ([], Map.empty) + go mb_b (a:as) = case f a of + Nothing -> + case go mb_b as of + (xs, yxs) -> + case mb_b of + Nothing -> (a:xs, yxs) + Just b -> (xs, Map.alter (alter_fn a) b yxs) + Just b -> go (Just b) as + alter_fn :: a -> Maybe [a] -> Maybe [a] + alter_fn a Nothing = Just [a] + alter_fn a (Just as) = Just (a:as) + +-------------------------------------------------- +-- Predicates used to filter which files we lint. + +hasSuffix :: Text -> Bool +hasSuffix fn = any (`T.isSuffixOf` fn) suffixes + where + suffixes = T.words ".hs .hsc .lhs .cabal .c .h .lhs-boot .hs-boot .x .y" + +autogenFiles :: [ Text ] +autogenFiles = [ "WCsubst.c", "iconv.c", "Table.hs" ] + +ignoredPrefixes :: [Text] +ignoredPrefixes = [ "testsuite/", "libraries/base/tests" + , "utils/hp2ps", "utils/hpc", "utils/unlit" + ] + +isTracked :: [Text] -> [Text] -> FilePath -> Bool +isTracked ignoredFiles ignoredDirs (T.pack -> fn) + = hasSuffix fn + && not (fn `elem` ignoredFiles) + && not (any (`T.isPrefixOf` fn) ignoredDirs) diff --git a/linters/lint-whitespace/cabal.project b/linters/lint-whitespace/cabal.project new file mode 100644 index 0000000000..444b636706 --- /dev/null +++ b/linters/lint-whitespace/cabal.project @@ -0,0 +1,2 @@ +packages: ., + ../linters-common diff --git a/linters/lint-whitespace/ghc.mk b/linters/lint-whitespace/ghc.mk new file mode 100644 index 0000000000..6b844911e5 --- /dev/null +++ b/linters/lint-whitespace/ghc.mk @@ -0,0 +1,18 @@ +# ----------------------------------------------------------------------------- +# +# (c) 2009 The University of Glasgow +# +# This file is part of the GHC build system. +# +# To understand how the build system works and how to modify it, see +# https://gitlab.haskell.org/ghc/ghc/wikis/building/architecture +# https://gitlab.haskell.org/ghc/ghc/wikis/building/modifying +# +# ----------------------------------------------------------------------------- + +linters/lint-whitespace_USES_CABAL = YES +linters/lint-whitespace_PACKAGE = lint-whitespace +linters/lint-whitespace_dist-install_PROGNAME = lint-whitespace +linters/lint-whitespace_dist-install_INSTALL = NO +linters/lint-whitespace_dist-install_INSTALL_INPLACE = YES +$(eval $(call build-prog,linters/lint-whitespace,dist-install,1)) diff --git a/linters/lint-whitespace/lint-whitespace.cabal b/linters/lint-whitespace/lint-whitespace.cabal new file mode 100644 index 0000000000..e3d2aa3a06 --- /dev/null +++ b/linters/lint-whitespace/lint-whitespace.cabal @@ -0,0 +1,31 @@ +cabal-version: 3.0 +name: lint-whitespace +version: 0.1.0.0 +synopsis: Lint whitespace +license: GPL-3.0-only +author: The GHC team +build-type: Simple + +executable lint-whitespace + + default-language: + Haskell2010 + + hs-source-dirs: + . + + main-is: + Main.hs + + build-depends: + linters-common, + mtl + >=2.1 && <2.3, + process + ^>= 1.6, + containers + ^>= 0.6, + base + >= 4.14 && < 5, + text + >= 1.2 && < 2.1, diff --git a/linters/linters-common/Linters/Common.hs b/linters/linters-common/Linters/Common.hs new file mode 100644 index 0000000000..8d92a87787 --- /dev/null +++ b/linters/linters-common/Linters/Common.hs @@ -0,0 +1,197 @@ +{-# LANGUAGE BangPatterns #-} +{-# LANGUAGE DerivingStrategies #-} +{-# LANGUAGE OverloadedStrings #-} + +{-# OPTIONS_GHC -Wno-incomplete-uni-patterns #-} + +module Linters.Common where + +-- base +import Control.Monad + ( liftM, unless ) +import Data.Function + ( on ) +import Data.List + ( groupBy ) +import Data.Maybe + ( fromMaybe ) +import GHC.IO.Encoding + ( utf8, setLocaleEncoding, getLocaleEncoding, textEncodingName ) + +-- deepseq +import Control.DeepSeq + ( NFData(rnf), force, ($!!) ) + +-- process +import System.Process + ( readProcess ) + +-- text +import Data.Text + ( Text ) +import qualified Data.Text as T + +-------------------------------------------------------------------------------- + +data LintMsg = LintMsg !LintLvl !Int !Text !Text + deriving stock Show + +data LintLvl = LintLvlWarn | LintLvlErr + deriving stock ( Show, Eq, Ord ) + +type GitRef = Text + +type Sh = IO + +silently :: a -> a +silently = id + +runGit :: FilePath -> Text -> [Text] -> Sh Text +runGit fp t ts = runGitStdin fp t ts "" + +-- | Run @git@ operation +runGitStdin :: FilePath -> Text -> [Text] -> Text -> Sh Text +runGitStdin d op args std_in = do + d' <- return $ T.pack d + out <- withUtf8 $ silently $ readProcess "git" (map T.unpack ("-C" : d' : op : args)) (T.unpack std_in) + return (T.pack out) + +-- | WARNING: non-reentrant Hack! +withUtf8 :: Sh a -> Sh a +withUtf8 act = do + oldloc <- getLocaleEncoding + if (textEncodingName oldloc == textEncodingName utf8) + then act + else do + setLocaleEncoding utf8 + r <- act + setLocaleEncoding oldloc + return r + +-- | wrapper around @git cat-file commit@ +-- +-- Returns (commit-header, commit-body) +gitCatCommit :: FilePath -> GitRef -> Sh (Text,Text) +gitCatCommit d ref = do + tmp <- runGit d "cat-file" ["commit", ref ] + return (fmap (T.drop 2) $ T.breakOn "\n\n" tmp) + +-- | wrapper around @git cat-file commit@ +gitCatBlob :: FilePath -> GitRef -> Sh Text +gitCatBlob d ref = do + tmpl <- liftM tread $ runGit d "cat-file" ["-s", ref] -- workaround shelly adding EOLs + tmp <- runGit d "cat-file" ["blob", ref] + return (T.take tmpl tmp) + where + tread = read . T.unpack + +-- | Wrapper around @git rev-parse --verify@ +-- +-- Normalise git ref to commit sha1 +gitNormCid :: FilePath -> GitRef -> Sh GitRef +gitNormCid d ref = do + tmp <- runGit d "rev-parse" ["-q", "--verify", ref <> "^{commit}" ] + return (T.strip tmp) + +-- | wrapper around @git branch --contains@ +gitBranchesContain :: FilePath -> GitRef -> Sh [Text] +gitBranchesContain d ref = do + tmp <- liftM T.lines $ + --errExit False $ print_stderr False $ + runGit d "branch" ["--contains", ref, "-r"] + + unless (all (\s -> T.take 2 s `elem` [" ","* "]) tmp) $ + fail "gitBranchesContain: internal error" + + return $!! map (T.drop 2) tmp + +-- | returns @[(path, (url, key))]@ +-- +-- may throw exception +getModules :: FilePath -> GitRef -> Sh [(Text, (Text, Text))] +getModules d ref = do + tmp <- runGit d "show" [ref <> ":.gitmodules"] + + res <- liftM T.lines $ runGitStdin d "config" [ "--file", "/dev/stdin", "-l" ] tmp + + let ms = [ (T.tail key1,(key2, T.tail val)) + | r <- res, "submodule." `T.isPrefixOf` r + , let (key,val) = T.break (=='=') r + , let (key',key2) = T.breakOnEnd "." key + , let (_,key1) = T.break (=='.') (T.init key') + ] + + ms' = [ (path', (url, k)) + | es@((k,_):_) <- groupBy ((==) `on` fst) ms + , let props = map snd es + , let url = fromMaybe (error "getModules1") (lookup "url" props) + , let path' = fromMaybe (error "getModules2") (lookup "path" props) + ] + + return $!! ms' + + +{- | + +Possible meanings of the 'Char' value: + + * Added (A), + * Copied (C), + * Deleted (D), + * Modified (M), + * Renamed (R), + * have their type (i.e. regular file, symlink, submodule, ...) changed (T), + * are Unmerged (U), + * are Unknown (X), + * or have had their pairing Broken (B). + +-} +gitDiffTree :: FilePath -> GitRef -> Sh (Text, [([(GitType, Text, Char)], (GitType, Text), Text)]) +gitDiffTree d ref = do + tmp <- liftM T.lines $ runGit d "diff-tree" ["--root","-c", "-r", ref] + case tmp of + cid:deltas -> return $!! (cid, map parseDtLine deltas) + [] -> return ("", []) + + where + parseDtLine :: Text -> ([(GitType, Text, Char)], (GitType, Text), Text) + parseDtLine l + | sanityCheck = force (zip3 (map cvtMode mode') oid' (T.unpack k),(cvtMode mode,oid),fp) + | otherwise = error "in parseDtLine" + where + sanityCheck = n > 0 && T.length k == n + + n = T.length cols + (mode',mode:tmp') = splitAt n $ T.split (==' ') l'' + (oid',[oid,k]) = splitAt n tmp' + [l'',fp] = T.split (=='\t') l' + (cols,l') = T.span (==':') l + +gitDiffTreePatch :: FilePath -> GitRef -> Text -> Sh Text +gitDiffTreePatch d ref fname = runGit d "diff-tree" ["--root", "--cc", "-r", ref, "--", fname] + +z40 :: GitRef +z40 = T.pack (replicate 40 '0') + +data GitType + = GitTypeVoid + | GitTypeRegFile + | GitTypeExeFile + | GitTypeTree + | GitTypeSymLink + | GitTypeGitLink + deriving stock (Show,Eq,Ord,Enum) + +instance NFData GitType where rnf !_ = () + +cvtMode :: Text -> GitType +cvtMode "000000" = GitTypeVoid +cvtMode "040000" = GitTypeSymLink +cvtMode "100644" = GitTypeRegFile +cvtMode "100755" = GitTypeExeFile +cvtMode "120000" = GitTypeSymLink +cvtMode "160000" = GitTypeGitLink +cvtMode x = error ("cvtMode: " ++ show x) + +tshow :: Show a => a -> Text +tshow = T.pack . show diff --git a/utils/notes-util/ghc.mk b/linters/linters-common/ghc.mk index 99f8628b70..409e3c9cc8 100644 --- a/utils/notes-util/ghc.mk +++ b/linters/linters-common/ghc.mk @@ -10,9 +10,8 @@ # # ----------------------------------------------------------------------------- -utils/notes-util_USES_CABAL = YES -utils/notes-util_PACKAGE = notes-util -utils/notes-util_dist-install_PROGNAME = notes-util -utils/notes-util_dist-install_INSTALL = NO -utils/notes-util_dist-install_INSTALL_INPLACE = YES -$(eval $(call build-prog,utils/notes-util,dist-install,1)) +linters/linters-common_USES_CABAL = YES +linters/linters-common_PACKAGE = linters-common +linters/linters-common_dist-install_INSTALL = YES +linters/linters-common_dist-install_INSTALL_INPLACE = YES +$(eval $(call build-package,linters/linters-common,dist-install,1)) diff --git a/linters/linters-common/linters-common.cabal b/linters/linters-common/linters-common.cabal new file mode 100644 index 0000000000..02245750dd --- /dev/null +++ b/linters/linters-common/linters-common.cabal @@ -0,0 +1,30 @@ +cabal-version: 3.0 +name: linters-common +version: 0.1.0.0 +synopsis: Common library for GHC linting scripts +license: GPL-3.0-only +author: The GHC team +build-type: Simple + +library + default-language: + Haskell2010 + + build-depends: + process + ^>= 1.6, + base + >= 4.14 && < 5, + text + >= 1.2 && < 2.1, + deepseq + >= 1.1, + + hs-source-dirs: + . + + ghc-options: + -Wall + + exposed-modules: + Linters.Common diff --git a/testsuite/mk/boilerplate.mk b/testsuite/mk/boilerplate.mk index 9fc9b36e23..03c281f76d 100644 --- a/testsuite/mk/boilerplate.mk +++ b/testsuite/mk/boilerplate.mk @@ -231,8 +231,12 @@ ifeq "$(COUNT_DEPS)" "" COUNT_DEPS := $(abspath $(TOP)/../inplace/bin/count-deps) endif -ifeq "$(NOTES_UTIL)" "" -NOTES_UTIL := $(abspath $(TOP)/../inplace/bin/notes-util) +ifeq "$(LINT_NOTES)" "" +LINT_NOTES := $(abspath $(TOP)/../inplace/bin/lint-notes) +endif + +ifeq "$(LINT_WHITESPACE)" "" +LINT_WHITESPACE := $(abspath $(TOP)/../inplace/bin/lint-whitespace) endif # ----------------------------------------------------------------------------- diff --git a/testsuite/tests/linters/Makefile b/testsuite/tests/linters/Makefile index 559d0bba3e..54ef4db132 100644 --- a/testsuite/tests/linters/Makefile +++ b/testsuite/tests/linters/Makefile @@ -1,11 +1,96 @@ TOP=../.. -ifeq "$(NOTES_UTIL)" "" -NOTES_UTIL := $(abspath $(TOP)/../inplace/bin/notes-util) +ifeq "$(LINT_NOTES)" "" +LINT_NOTES := $(abspath $(TOP)/../inplace/bin/lint-notes) +endif + +ifeq "$(LINT_WHITESPACE)" "" +LINT_WHITESPACE := $(abspath $(TOP)/../inplace/bin/lint-whitespace) endif uniques: python3 checkUniques/check-uniques.py $(TOP)/.. +makefiles: + (cd $(TOP)/tests/linters/ && python3 regex-linters/check-makefiles.py tracked) + +version-number: + regex-linters/check-version-number.sh ${TOP}/.. + +cpp: + (cd $(TOP)/tests/linters/ && python3 regex-linters/check-cpp.py tracked) + +changelogs: + regex-linters/check-changelogs.sh $(TOP)/.. + notes: - (cd $(TOP)/.. && $(NOTES_UTIL) broken-refs) + (cd $(TOP)/.. && $(LINT_NOTES) broken-refs) + +whitespace: + (cd $(TOP)/.. &&\ + $(LINT_WHITESPACE) tracked\ + --ignore-dirs\ + testsuite\ + libraries/base/cbits\ + libraries/base/tests\ + utils/hp2ps\ + utils/hpc\ + utils/unlit\ + --ignore-files\ + libraries/base/GHC/IO/Encoding/CodePage/Table.hs\ + libraries/base/Control/Concurrent/QSem.hs\ + libraries/base/Control/Concurrent/QSemN.hs\ + libraries/base/Control/Monad/ST/Imp.hs\ + libraries/base/Control/Monad/ST/Lazy.hs\ + libraries/base/Data/Char.hs\ + libraries/base/Data/Eq.hs\ + libraries/base/Data/IORef.hs\ + libraries/base/Data/Int.hs\ + libraries/base/Data/Ix.hs\ + libraries/base/Data/Ratio.hs\ + libraries/base/Data/STRef/Lazy.hs\ + libraries/base/Data/STRef/Strict.hs\ + libraries/base/Foreign.hs\ + libraries/base/Foreign/C.hs\ + libraries/base/Foreign/Concurrent.hs\ + libraries/base/Foreign/ForeignPtr.hs\ + libraries/base/Foreign/ForeignPtr/Imp.hs\ + libraries/base/Foreign/ForeignPtr/Safe.hs\ + libraries/base/Foreign/ForeignPtr/Unsafe.hs\ + libraries/base/Foreign/Marshal.hs\ + libraries/base/Foreign/Marshal/Alloc.hs\ + libraries/base/Foreign/Marshal/Error.hs\ + libraries/base/Foreign/Marshal/Safe.hs\ + libraries/base/Foreign/Marshal/Unsafe.hs\ + libraries/base/Foreign/Safe.hs\ + libraries/base/Foreign/StablePtr.hs\ + libraries/base/Foreign/Storable.hs\ + libraries/base/GHC/IO/Encoding/Latin1.hs\ + libraries/base/GHC/IO/Encoding/Types.hs\ + libraries/base/GHC/IO/Handle/FD.hs\ + libraries/base/GHC/IO/IOMode.hs\ + libraries/base/System/Console/GetOpt.hs\ + libraries/base/System/IO/Unsafe.hs\ + libraries/base/System/Mem.hs\ + libraries/base/Text/Show.hs\ + libraries/base/include/HsBase.h\ + libraries/base/include/HsEvent.h\ + libraries/base/include/md5.h\ + libraries/ghc-prim/GHC/Tuple.hs\ + libraries/template-haskell/Language/Haskell/TH/Quote.hs\ + rts/STM.h\ + rts/Sparks.h\ + rts/Threads.h\ + rts/hooks/OnExit.c\ + rts/sm/Evac.h\ + rts/sm/MarkStack.h\ + rts/sm/MarkWeak.h\ + rts/sm/Scav.h\ + rts/sm/Sweep.c\ + rts/sm/Sweep.h\ + rts/win32/veh_excn.h\ + utils/genprimopcode/Parser.y\ + utils/genprimopcode/Syntax.hs\ + utils/lndir/lndir-Xos.h\ + utils/lndir/lndir-Xosdefs.h\ + ) diff --git a/testsuite/tests/linters/all.T b/testsuite/tests/linters/all.T index ef3ea5441f..0eefb0f9a4 100644 --- a/testsuite/tests/linters/all.T +++ b/testsuite/tests/linters/all.T @@ -14,8 +14,27 @@ def has_ls_files() -> bool: except subprocess.CalledProcessError: return False +test('makefiles', [ no_deps if has_ls_files() else skip + , extra_files(["regex-linters"]) ] + , makefile_test, ['makefiles']) -test('notes', [no_deps if has_ls_files() else skip - , req_hadrian_deps(["lint:notes-util"]) +test('changelogs', [ no_deps if has_ls_files() else skip + , extra_files(["regex-linters"]) ] + , makefile_test, ['changelogs']) + +test('cpp', [ no_deps if has_ls_files() else skip + , extra_files(["regex-linters"]) ] + , makefile_test, ['cpp']) + +test('version-number', [ no_deps if has_ls_files() else skip + , extra_files(["regex-linters"]) ] + , makefile_test, ['version-number']) + +test('notes', [ no_deps if has_ls_files() else skip + , req_hadrian_deps(["lint:notes"]) , normalise_fun(normalise_nos) ] - , makefile_test, ['notes']) + , makefile_test, ['notes']) + +test('whitespace', [ no_deps if has_ls_files() else skip + , req_hadrian_deps(["lint:whitespace"]) ] + , makefile_test, ['whitespace']) diff --git a/testsuite/tests/linters/changelogs.stdout b/testsuite/tests/linters/changelogs.stdout new file mode 100644 index 0000000000..9547d7b24b --- /dev/null +++ b/testsuite/tests/linters/changelogs.stdout @@ -0,0 +1 @@ +[32mChangelogs look OK (no "TBA"s, or RELEASE=NO)[0m diff --git a/testsuite/tests/linters/notes.stdout b/testsuite/tests/linters/notes.stdout index 8e4ad38ac8..57d2aa1367 100644 --- a/testsuite/tests/linters/notes.stdout +++ b/testsuite/tests/linters/notes.stdout @@ -22,11 +22,11 @@ ref compiler/GHC/Core/Unfold.hs:1242:50: Note [Unfold info lazy contexts] ref compiler/GHC/Core/Unfold/Make.hs:157:34: Note [DFunUnfoldings] ref compiler/GHC/Core/Unify.hs:544:16: Note [Unification result] ref compiler/GHC/Core/Unify.hs:1390:9: Note [INLINE pragmas and (>>)] -ref compiler/GHC/Core/Utils.hs:944:40: Note [ _ -> [con1] -ref compiler/GHC/CoreToStg.hs:460:15: Note [Nullary unboxed tuple] -ref compiler/GHC/Driver/Main.hs:1551:34: Note [simpleTidyPgm - mkBootModDetailsTc] -ref compiler/GHC/Driver/Session.hs:1949:36: Note [GHC.Driver.Main . Safe Haskell Inference] -ref compiler/GHC/Driver/Session.hs:3910:49: Note [Eta-reduction in -O0] +ref compiler/GHC/Core/Utils.hs:947:40: Note [ _ -> [con1] +ref compiler/GHC/CoreToStg.hs:462:15: Note [Nullary unboxed tuple] +ref compiler/GHC/Driver/Main.hs:1566:34: Note [simpleTidyPgm - mkBootModDetailsTc] +ref compiler/GHC/Driver/Session.hs:1947:36: Note [GHC.Driver.Main . Safe Haskell Inference] +ref compiler/GHC/Driver/Session.hs:3916:49: Note [Eta-reduction in -O0] ref compiler/GHC/Hs/Extension.hs:140:5: Note [Strict argument type constraints] ref compiler/GHC/HsToCore/Binds.hs:313:33: Note [AbsBinds wrappers] ref compiler/GHC/HsToCore/Binds.hs:849:46: Note [Free dictionaries] @@ -39,8 +39,8 @@ ref compiler/GHC/HsToCore/Docs.hs:130:0: Note [1] ref compiler/GHC/HsToCore/Pmc/Solver.hs:853:20: Note [COMPLETE sets on data families] ref compiler/GHC/HsToCore/Types.hs:61:13: Note [Generating fresh names for FFI wrappers] ref compiler/GHC/HsToCore/Utils.hs:939:62: Note [Don't CPR join points] -ref compiler/GHC/Iface/Syntax.hs:705:0: Note [Minimal complete definition] -ref compiler/GHC/Iface/Syntax.hs:765:44: Note [Minimal complete definition] +ref compiler/GHC/Iface/Syntax.hs:708:0: Note [Minimal complete definition] +ref compiler/GHC/Iface/Syntax.hs:768:44: Note [Minimal complete definition] ref compiler/GHC/Parser/Lexer.x:185:7: Note [Lexing NumericUnderscores extension] ref compiler/GHC/Parser/Lexer.x:502:3: Note [Lexing NumericUnderscores extension] ref compiler/GHC/Rename/Expr.hs:2013:9: Note [ApplicativeDo and strict patterns] @@ -52,10 +52,10 @@ ref compiler/GHC/Rename/Pat.hs:888:29: Note [Disambiguating record fields ref compiler/GHC/Rename/Splice.hs:450:27: Note [Splices] ref compiler/GHC/Runtime/Eval.hs:996:2: Note [Querying instances for a type] ref compiler/GHC/Runtime/Interpreter.hs:198:30: Note [uninterruptibleMask_] -ref compiler/GHC/StgToCmm.hs:107:18: Note [codegen-split-init] -ref compiler/GHC/StgToCmm.hs:110:18: Note [pipeline-split-init] -ref compiler/GHC/StgToCmm/Expr.hs:491:4: Note [case on bool] -ref compiler/GHC/StgToCmm/Expr.hs:751:3: Note [alg-alt heap check] +ref compiler/GHC/StgToCmm.hs:108:18: Note [codegen-split-init] +ref compiler/GHC/StgToCmm.hs:111:18: Note [pipeline-split-init] +ref compiler/GHC/StgToCmm/Expr.hs:585:4: Note [case on bool] +ref compiler/GHC/StgToCmm/Expr.hs:848:3: Note [alg-alt heap check] ref compiler/GHC/Tc/Errors.hs:180:13: Note [Fail fast on kind errors] ref compiler/GHC/Tc/Errors.hs:2016:0: Note [Highlighting ambiguous type variables] ref compiler/GHC/Tc/Errors/Ppr.hs:1760:11: Note [Highlighting ambiguous type variables] @@ -82,10 +82,10 @@ ref compiler/GHC/Tc/Gen/Pat.hs:1376:16: Note [Pattern coercions] ref compiler/GHC/Tc/Gen/Sig.hs:78:10: Note [Overview of type signatures] ref compiler/GHC/Tc/Instance/Family.hs:515:35: Note [Constrained family instances] ref compiler/GHC/Tc/Module.hs:698:15: Note [Extra dependencies from .hs-boot files] -ref compiler/GHC/Tc/Module.hs:1901:19: Note [Root-main id] -ref compiler/GHC/Tc/Module.hs:1971:6: Note [Root-main id] +ref compiler/GHC/Tc/Module.hs:1904:19: Note [Root-main id] +ref compiler/GHC/Tc/Module.hs:1974:6: Note [Root-main id] ref compiler/GHC/Tc/Solver.hs:2541:36: Note [Kind generalisation and SigTvs] -ref compiler/GHC/Tc/Solver/Canonical.hs:1228:33: Note [Canonical LHS] +ref compiler/GHC/Tc/Solver/Canonical.hs:1229:33: Note [Canonical LHS] ref compiler/GHC/Tc/Solver/Interact.hs:1638:9: Note [No touchables as FunEq RHS] ref compiler/GHC/Tc/Solver/Interact.hs:2292:12: Note [The equality class story] ref compiler/GHC/Tc/Solver/Rewrite.hs:1032:7: Note [Stability of rewriting] @@ -96,9 +96,9 @@ ref compiler/GHC/Tc/TyCl.hs:4366:16: Note [rejigCon and c.f. Note [Check ref compiler/GHC/Tc/TyCl/Instance.hs:947:26: Note [Generalising in tcFamTyPatsGuts] ref compiler/GHC/Tc/Types.hs:647:17: Note [Generating fresh names for FFI wrappers] ref compiler/GHC/Tc/Types.hs:696:33: Note [Extra dependencies from .hs-boot files] -ref compiler/GHC/Tc/Types.hs:1145:28: Note [Don't promote data constructors with non-equality contexts] -ref compiler/GHC/Tc/Types.hs:1221:36: Note [Bindings with closed types] -ref compiler/GHC/Tc/Types.hs:1457:47: Note [Care with plugin imports] +ref compiler/GHC/Tc/Types.hs:1154:28: Note [Don't promote data constructors with non-equality contexts] +ref compiler/GHC/Tc/Types.hs:1230:36: Note [Bindings with closed types] +ref compiler/GHC/Tc/Types.hs:1466:47: Note [Care with plugin imports] ref compiler/GHC/Tc/Types/Constraint.hs:238:34: Note [NonCanonical Semantics] ref compiler/GHC/Tc/Utils/Concrete.hs:246:2: Note [Concrete and Concrete#] ref compiler/GHC/Tc/Utils/Env.hs:556:7: Note [Bindings with closed types] @@ -109,8 +109,8 @@ ref compiler/GHC/Tc/Utils/TcMType.hs:793:7: Note [Kind checking for GADTs ref compiler/GHC/Tc/Utils/TcType.hs:529:7: Note [TyVars and TcTyVars] ref compiler/GHC/ThToHs.hs:1738:11: Note [Adding parens for splices] ref compiler/GHC/ThToHs.hs:1749:3: Note [Adding parens for splices] -ref compiler/GHC/Types/Basic.hs:586:17: Note [Safe Haskell isSafeOverlap] -ref compiler/GHC/Types/Basic.hs:1326:7: Note [Activation competition] +ref compiler/GHC/Types/Basic.hs:619:17: Note [Safe Haskell isSafeOverlap] +ref compiler/GHC/Types/Basic.hs:1359:7: Note [Activation competition] ref compiler/GHC/Types/Demand.hs:307:25: Note [Preserving Boxity of results is rarely a win] ref compiler/GHC/Types/Demand.hs:1100:4: Note [Use one-shot information] ref compiler/GHC/Types/Error.hs:358:3: Note [Suppressing Messages] @@ -124,14 +124,16 @@ ref compiler/Language/Haskell/Syntax/Expr.hs:1561:32: Note [Quasi-quote o ref compiler/Language/Haskell/Syntax/Pat.hs:336:12: Note [Disambiguating record fields] ref configure.ac:212:10: Note [Linking ghc-bin against threaded stage0 RTS] ref docs/core-spec/core-spec.mng:177:6: Note [TyBinders] -ref ghc/GHCi/UI.hs:3630:25: Note [ModBreaks.decls] +ref ghc/GHCi/UI.hs:3646:25: Note [ModBreaks.decls] ref ghc/ghc.mk:62:6: Note [Linking ghc-bin against threaded stage0 RTS] ref hadrian/src/Expression.hs:130:30: Note [Linking ghc-bin against threaded stage0 RTS] ref libraries/base/GHC/ST.hs:139:7: Note [Definition of runRW#] +ref linters/lint-notes/Notes.hs:32:29: Note [" <> T.unpack x <> "] +ref linters/lint-notes/Notes.hs:69:22: Note [...] ref testsuite/config/ghc:212:10: Note [WayFlags] ref testsuite/driver/testlib.py:152:10: Note [Why is there no stage1 setup function?] ref testsuite/driver/testlib.py:156:2: Note [Why is there no stage1 setup function?] -ref testsuite/mk/boilerplate.mk:259:2: Note [WayFlags] +ref testsuite/mk/boilerplate.mk:263:2: Note [WayFlags] ref testsuite/tests/indexed-types/should_fail/ExtraTcsUntch.hs:30:27: Note [Extra TcS Untouchables] ref testsuite/tests/perf/join_points/join005.hs:19:63: Note [Don't CPR join points] ref testsuite/tests/perf/should_run/all.T:3:6: Note [Solving from instances when interacting Dicts] @@ -149,7 +151,5 @@ ref testsuite/tests/typecheck/should_compile/tc228.hs:9:7: Note [Inferenc ref testsuite/tests/typecheck/should_compile/tc231.hs:12:16: Note [Important subtlety in oclose] ref testsuite/tests/typecheck/should_fail/UnliftedNewtypesMultiFieldGadt.hs:11:28: Note [Kind-checking the field type] ref testsuite/tests/typecheck/should_fail/tcfail093.hs:13:7: Note [Important subtlety in oclose] -ref utils/notes-util/Notes.hs:33:29: Note [" <> T.unpack x <> "] -ref utils/notes-util/Notes.hs:70:22: Note [...] -ref validate:413:14: Note [Why is there no stage1 setup function?] +ref validate:412:14: Note [Why is there no stage1 setup function?] diff --git a/testsuite/tests/linters/regex-linters/check-changelogs.sh b/testsuite/tests/linters/regex-linters/check-changelogs.sh new file mode 100755 index 0000000000..10fca9d5c0 --- /dev/null +++ b/testsuite/tests/linters/regex-linters/check-changelogs.sh @@ -0,0 +1,16 @@ +#!/usr/bin/env bash + +set -e + +COLOR_RED="\e[31m" +COLOR_GREEN="\e[32m" +COLOR_NONE="\e[0m" + +if grep -E -q 'RELEASE=YES' ${1}/configure.ac && grep TBA ${1}/libraries/*/changelog.md +then + echo -e "${COLOR_RED}Error: Found \"TBA\"s in changelogs.${COLOR_NONE}" + exit 1 +else + echo -e "${COLOR_GREEN}Changelogs look OK (no \"TBA\"s, or RELEASE=NO)${COLOR_NONE}" + exit 0 +fi diff --git a/.gitlab/linters/check-cpp.py b/testsuite/tests/linters/regex-linters/check-cpp.py index ffa430e10d..4cc2257984 100755..100644 --- a/.gitlab/linters/check-cpp.py +++ b/testsuite/tests/linters/regex-linters/check-cpp.py @@ -37,6 +37,8 @@ for l in linters: 'images')) # Don't lint core spec l.add_path_filter(lambda path: not path.name == 'core-spec.pdf') + # Don't lint the linter itself + l.add_path_filter(lambda path: not path.name == 'check-cpp.py') if __name__ == '__main__': run_linters(linters) diff --git a/.gitlab/linters/check-makefiles.py b/testsuite/tests/linters/regex-linters/check-makefiles.py index 5a8286c6a7..5a8286c6a7 100755..100644 --- a/.gitlab/linters/check-makefiles.py +++ b/testsuite/tests/linters/regex-linters/check-makefiles.py diff --git a/.gitlab/linters/check-version-number.sh b/testsuite/tests/linters/regex-linters/check-version-number.sh index 4f478e487a..2ce68627f4 100755 --- a/.gitlab/linters/check-version-number.sh +++ b/testsuite/tests/linters/regex-linters/check-version-number.sh @@ -2,6 +2,6 @@ set -e -grep -E -q 'RELEASE=NO' configure.ac || - grep -E -q '\[[0-9]+\.[0-9]+\.[0-9]+\]' configure.ac || +grep -E -q 'RELEASE=NO' ${1}/configure.ac || + grep -E -q '\[[0-9]+\.[0-9]+\.[0-9]+\]' ${1}/configure.ac || ( echo "error: configure.ac: GHC version number must have three components when RELEASE=YES."; exit 1 ) diff --git a/.gitlab/linters/linter.py b/testsuite/tests/linters/regex-linters/linter.py index 61fe18de33..2246dcce30 100644 --- a/.gitlab/linters/linter.py +++ b/testsuite/tests/linters/regex-linters/linter.py @@ -38,6 +38,12 @@ def get_changed_files(base_commit: str, head_commit: str, files = subprocess.check_output(cmd) return files.decode('UTF-8').split('\n') +def get_tracked_files(subdir: str = '.'): + """ Get the files tracked by git in the given subdirectory. """ + cmd = ['git', 'ls-tree', '--name-only', '-r', 'HEAD', subdir] + files = subprocess.check_output(cmd) + return files.decode('UTF-8').split('\n') + Warning = namedtuple('Warning', 'path,line_no,line_content,message') class Linter(object): @@ -106,15 +112,19 @@ def run_linters(linters: Sequence[Linter], subparser.set_defaults(get_linted_files=lambda args: get_changed_files(args.base, args.head, subdir)) - subparser = subparsers.add_parser('files', help='Lint a range of commits') + subparser = subparsers.add_parser('files', help='Lint the given files') subparser.add_argument('file', nargs='+', help='File to lint') subparser.set_defaults(get_linted_files=lambda args: args.file) + subparser = subparsers.add_parser('tracked', help="Lint files tracked by Git") + subparser.set_defaults(get_linted_files=lambda args: + get_tracked_files(subdir)) + args = parser.parse_args() linted_files = args.get_linted_files(args) for path in linted_files: - if path.startswith('.gitlab/linters'): + if path.startswith('linters'): continue for linter in linters: linter.do_lint(Path(path)) diff --git a/testsuite/tests/linters/whitespace.stdout b/testsuite/tests/linters/whitespace.stdout new file mode 100644 index 0000000000..b773a1831d --- /dev/null +++ b/testsuite/tests/linters/whitespace.stdout @@ -0,0 +1 @@ +whitespace validation passed! |