diff options
Diffstat (limited to 'linters/lint-commit-msg/Main.hs')
| -rw-r--r-- | linters/lint-commit-msg/Main.hs | 160 |
1 files changed, 160 insertions, 0 deletions
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 |