content: {-# LANGUAGE BlockArguments #-}
  {-# LANGUAGE MultiWayIf #-}
  {-# LANGUAGE ScopedTypeVariables #-}
  {-# LANGUAGE OverloadedStrings #-}
  {-# LANGUAGE ViewPatterns #-}
  
  module LintCodes.Coverage
    ( getCoveredCodes )
    where
  
  -- base
  import Data.Char
    ( isAlphaNum, isDigit, isSpace, toUpper )
  import Data.Maybe
    ( mapMaybe )
  import Data.List
    ( dropWhileEnd )
  import System.Info
    ( os )
  
  -- bytestring
  import qualified Data.ByteString as ByteString
    ( readFile )
  
  -- containers
  import Data.Set
    ( Set )
  import qualified Data.Set as Set
    ( fromList )
  
  -- directory
  import System.Directory
    ( doesDirectoryExist, listDirectory, makeAbsolute )
  
  -- filepath
  import System.FilePath
    ( (</>), takeExtension )
  
  -- ghc
  import GHC.Types.Error
    ( DiagnosticCode(..) )
  
  -- process
  import System.Process
    ( readProcess )
  
  -- text
  import Data.Text
    ( Text )
  import qualified Data.Text as Text
  import qualified Data.Text.Encoding as Text
    ( decodeUtf8' )
  
  -- transformers
  import Control.Monad.Trans.State.Strict
    ( State, runState, get, put )
  
  --------------------------------------------------------------------------------
  -- Diagnostic code coverage from testsuite .stdout and .stderr files
  
  -- | Get all diagnostic codes that appear in testsuite .stdout and .stderr
  -- files.
  getCoveredCodes :: IO (Set DiagnosticCode)
  getCoveredCodes =
    do { top <- dropWhileEnd isSpace
            <$> readProcess "git" ["rev-parse", "--show-toplevel"] ""
         -- TODO: would be better to avoid using git entirely.
  
         -- When run inside an MSYS shell, git may return a Unix-style path
         -- like /c/Blah. System.Directory doesn't like that, so we make sure
         -- to turn that into C:/Blah. See #25178.
       ; top' <- fixupMsysDrive top
       ; let testRoot = top' </> "testsuite" </> "tests"
       ; traverseFilesFrom includeFile diagnosticCodesIn testRoot
       }
  
  -- | Excluded files: we don't look for diagnostic codes in these, as they
  -- are not actual diagnostic codes emitted by the compiler.
  excludeList :: [ FilePath ]
  excludeList = [ "codes.stdout" ]
  
  -- | Which files should we include in the search for diagnostic codes in the
  -- output of the testsuite: `.stdout` and `.stderr` files.
  includeFile :: FilePath -> Bool
  includeFile fn
    =  fn `notElem` excludeList
    && takeExtension fn `elem` [ ".stdout", ".stderr" ]
  
  -- | Collect all diagnostic codes mentioned in the given 'Text'.
  diagnosticCodesIn :: Text -> Set DiagnosticCode
  diagnosticCodesIn txt =
    Set.fromList $ mapMaybe getCode
                 $ concatMap (enclosedBy '[' ']')
                 $ Text.lines txt
  
    where
      getCode :: Text -> Maybe DiagnosticCode
      getCode txt_inside_brackets
        | let (ns, Text.drop 1 -> code) = Text.breakOn "-" txt_inside_brackets
        , not $ Text.null ns
        , not $ Text.null code
        , Text.all isAlphaNum ns
        , Text.all isDigit code
        , let ns' = Text.unpack ns
        = let diag = DiagnosticCode ns' ( read $ Text.unpack code )
          in if ns' `elem` expectedDiagnosticNameSpaces
             then Just diag
             else Nothing
               -- error "lint-codes: unexpected diagnostic code [" ++ show diag ++ "]."
        | otherwise
        = Nothing
  
  -- | Which diagnostic code namespaces are relevant to this test?
  expectedDiagnosticNameSpaces :: [String]
  expectedDiagnosticNameSpaces = ["GHC"]
  
  -- | Capture pieces of a text enclosed by matching delimiters.
  --
  -- > enclosedBy '(' ')' "ab(cd(e)f)g(hk)l"
  -- > ["cd(e)f", "hk"]
  enclosedBy :: Char -> Char -> Text -> [Text]
  enclosedBy open close = go . recur
    where
      recur = Text.breakOn (Text.singleton open)
      go (_, Text.drop 1 -> rest)
        | Text.null rest
        = []
        | let ((ok, rest'), n) = ( `runState` 1 ) $ Text.spanM matchingParen rest
        = if n == 0
          then (if Text.null ok then id else (ok:)) $ go $ recur rest'
          else []
  
      matchingParen :: Char -> State Int Bool
      matchingParen c =
        do { s <- get
           ; if | c == open
                -> do { put (s+1); return True }
                | c == close
                -> do { put (s-1); return (s /= 1) }
                | otherwise
                -> return True }
  
  -- | Recursive traversal from a root directory of all files satisfying
  -- the inclusion predicate, collecting up a result according to
  -- the parsing function.
  traverseFilesFrom :: forall b. Monoid b
                    => ( FilePath -> Bool ) -- ^ inclusion predicate
                    -> ( Text -> b )        -- ^ parsing function
                    -> FilePath             -- ^ directory root
                    -> IO b
  traverseFilesFrom include_file parse_contents = go
    where
      go top
       = do { ps <- listDirectory top
            ; (`foldMap` ps) \ p ->
         do { let path = top </> p
            ; is_dir <- doesDirectoryExist path
            ; if is_dir
              then go path
              else if not $ include_file p
              then return mempty
              else
          do { bs <- ByteString.readFile path
             ; return $ case Text.decodeUtf8' bs of
             { Left  _   -> mempty
             ; Right txt -> parse_contents txt
             } } } }
  
  -- | On Windows, change MSYS-style @/c/Blah@ to @C:/Blah@. See #25178.
  fixupMsysDrive :: FilePath -> IO FilePath
  fixupMsysDrive fp = do
    fixedUp <-
      if | os == "mingw32" || os == "win32"
         , ('/':drv:'/':rest) <- fp
         -> return $ toUpper drv : ':':'/':rest
         | otherwise
         -> return fp
    makeAbsolute fixedUp
  