content: {-# 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
  