content: {-# LANGUAGE BangPatterns #-}
  {-# LANGUAGE BlockArguments #-}
  {-# LANGUAGE TupleSections #-}
  
  module Main where
  
  -- base
  import Control.Monad
    ( when )
  import Data.List
    ( sortOn )
  import Text.Printf
    ( printf )
  import System.Environment
    ( getArgs )
  
  -- containers
  import Data.Map.Strict
    ( Map )
  import qualified Data.Map.Strict as Map
    ( (\\), intersection, mapMaybe, toList, withoutKeys )
  
  -- ghc
  import GHC.Types.Error
    ( DiagnosticCode(..) )
  
  -- lint-codes
  import LintCodes.Args
    ( Mode(..), parseArgs )
  import LintCodes.Static
    ( FamEqnIndex, Use, used, outdated
    , getFamEqnCodes
    , staticallyUsedCodes
    )
  import LintCodes.Coverage
    ( getCoveredCodes )
  
  --------------------------------------------------------------------------------
  
  main :: IO ()
  main = do
  
    args <- getArgs
    let !(!mode, mb_libDir) = parseArgs args
  
    famEqnCodes <- getFamEqnCodes mb_libDir
  
    case mode of
      Test     -> testCodes         famEqnCodes
      List     -> listCodes         famEqnCodes
      Outdated -> listOutdatedCodes famEqnCodes
  
  -- | List all statically used diagnostic codes.
  listCodes :: Map DiagnosticCode ( FamEqnIndex, String, Use ) -> IO ()
  listCodes famEqnCodes = do
    let usedCodes = Map.mapMaybe used famEqnCodes
                   `Map.intersection` staticallyUsedCodes
    putStrLn $ showDiagnosticCodesWith printCode usedCodes
  
  -- | List all outdated diagnostic codes.
  listOutdatedCodes :: Map DiagnosticCode ( FamEqnIndex, String, Use ) -> IO ()
  listOutdatedCodes famEqnCodes = do
    let outdatedCodes = Map.mapMaybe outdated famEqnCodes
    putStrLn $ showDiagnosticCodesWith printCode outdatedCodes
  
  -- | Test consistency and coverage of diagnostic codes.
  --
  -- Assumes we are in a GHC Git tree, as we look at all testsuite .stdout and
  -- .stderr files.
  testCodes :: Map DiagnosticCode ( FamEqnIndex, String, Use ) -> IO ()
  testCodes famEqnCodes = do
  
    ------------------------------
    -- Static consistency checks.
  
    let
      familyEqnUsedCodes = Map.mapMaybe used famEqnCodes
      familyEqnOutdatedCodes = Map.mapMaybe outdated famEqnCodes
  
      -- Consistency of diagnostic codes:
      --   all diagnostic codes returned by the 'GhcDiagnosticCode' type family
      --   should be statically used, unless they are marked as outdated.
      staticallyUnusedCodes = familyEqnUsedCodes Map.\\ staticallyUsedCodes
  
      -- Consistency of outdated diagnostic codes:
      --   if a diagnostic code is marked as outdated, it should not be statically used.
      outdatedStaticallyUsedCodes =
        familyEqnOutdatedCodes `Map.intersection` staticallyUsedCodes
  
    -- Test 1: all non-outdated 'GhcDiagnosticCode' equations are statically used.
    let plural1 = length staticallyUnusedCodes > 1
        test1OK :: Bool
        test1Message :: String
        (test1OK, test1Message)
          | null staticallyUnusedCodes
          = (True,) $
            "- All non-outdated 'GhcDiagnosticCode' equations are statically used."
          | otherwise
          = (False,) $
            unlines [ "- The following 'GhcDiagnosticCode' equation" ++ (if plural1 then "s appear" else " appears") ++ " to be unused."
                    , "  If " ++ (if plural1 then "any of these codes are indeed no longer used, but were"
                                             else "this code is indeed no longer used, but was")
                    , "  emitted by a previous version of GHC, you should mark " ++ (if plural1 then "them" else "it") ++ " as outdated"
                    , "  by tagging the RHS of the appropriate type family equation of"
                    , "  the 'GhcDiagnosticCode' type family in 'GHC.Types.Error.Codes'"
                    , "  with the 'Outdated' type synonym."
                    , ""
                    , showDiagnosticCodesWith printUnused staticallyUnusedCodes
                    ]
    putStrLn ""
    putStrLn test1Message
    putStrLn ""
  
    -- Test 2: all outdated 'GhcDiagnosticCode' equations are statically unused.
    let plural2 = length outdatedStaticallyUsedCodes > 1
        test2OK :: Bool
        test2Message :: String
        (test2OK, test2Message)
          | null outdatedStaticallyUsedCodes
          = (True,) $
            "- All outdated 'GhcDiagnosticCode' equations are statically unused."
          | otherwise
          = (False,) $
            unlines [ "- The following 'GhcDiagnosticCode' equation" ++ (if plural2 then "s are" else " is") ++ " still in use,"
                    , "  even though " ++ (if plural2 then "they are" else "it is") ++ " marked as being outdated."
                    , "  Perhaps you should remove the 'Outdated' tag on " ++ (if plural2 then "them" else "it") ++ "."
                    , ""
                    , showDiagnosticCodesWith printOutdatedUsed outdatedStaticallyUsedCodes
                    ]
    putStrLn test2Message
    putStrLn ""
  
    -------------------------
    -- Code coverage checks.
  
    -- Test 3: all statically used diagnostic codes are covered by the testsuite,
    -- (exceptions are allowed in the test output).
    coveredCodes <- getCoveredCodes
    when ( null coveredCodes ) $
      error $ unlines [ "internal error in 'lint-codes' test:"
                      , "  failed to parse any diagnostic codes from the testsuite"
                      ]
  
    let uncoveredCodes :: Map DiagnosticCode (FamEqnIndex, String)
        uncoveredCodes = (familyEqnUsedCodes `Map.intersection` staticallyUsedCodes)
                       `Map.withoutKeys` coveredCodes
        plural3 = length uncoveredCodes > 1
        test3OK :: Bool
        test3Message :: String
        (test3OK, test3Message)
          | null uncoveredCodes
          = (True,) $
            "- All diagnostic codes are covered by the testsuite."
          | otherwise
          = (False,) $
            unlines [ "- The following diagnostic code" ++ (if plural3 then "s seem" else " seems") ++ " to not be covered by any tests,"
                    , "  as determined by analysing all '.stderr' and '.stdout' files in the testsuite."
                    , "  If there is a change in the expected output of this test, you can:"
                    , "    - add test cases to exercise any newly uncovered diagnostic codes,"
                    , "    - accept the expected output of the 'codes' test by passing the '-a' flag to Hadrian."
                    , ""
                    , showDiagnosticCodesWith printUntested uncoveredCodes
                    ]
  
    putStrLn test3Message
    when (test1OK && test2OK && test3OK) do
      putStrLn ""
      putStrLn "All good!"
  
  -- | Show a collection of diagnostic codes, ordered by the index in which
  -- the diagnostic code appears in the 'GhcDiagnosticCode' type family.
  showDiagnosticCodesWith :: ( (DiagnosticCode, String) -> String )
                             -- ^ how to print each diagnostic code
                          -> Map DiagnosticCode (FamEqnIndex, String) -> String
  showDiagnosticCodesWith f codes = unlines $ map showCodeCon $ sortOn famEqnIndex $ Map.toList codes
    where
      showCodeCon :: (DiagnosticCode, (FamEqnIndex, String)) -> String
      showCodeCon (code, (_, con)) = f (code, con)
      famEqnIndex :: (DiagnosticCode, (FamEqnIndex, String)) -> FamEqnIndex
      famEqnIndex (_, (i,_)) = i
  
  printUnused, printOutdatedUsed, printUntested, printCode :: (DiagnosticCode, String) -> String
  printUnused (code, con) =
    "Unused equation: GhcDiagnosticCode " ++ show con ++ " = " ++ showDiagnosticCodeNumber code
  printOutdatedUsed (code, con) =
    "Outdated equation is used: GhcDiagnosticCode " ++ show con ++ " = Outdated " ++ showDiagnosticCodeNumber code
  printUntested (code, con) =
    "[" ++ show code ++ "] is untested (constructor = " ++ con ++ ")"
  printCode (code, con) =
    "[" ++ show code ++ "] " ++ show con
  
  showDiagnosticCodeNumber :: DiagnosticCode -> String
  showDiagnosticCodeNumber (DiagnosticCode { diagnosticCodeNumber = c })
    = printf "%05d" c
  