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.

4 files changed, 316 insertions, 0 deletions

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,