diff options
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! |