content: {-# LANGUAGE BlockArguments            #-}
  {-# LANGUAGE FlexibleContexts          #-}
  {-# LANGUAGE LambdaCase                #-}
  {-# LANGUAGE NamedFieldPuns            #-}
  {-# LANGUAGE OverloadedStrings         #-}
  {-# LANGUAGE RecordWildCards           #-}
  
  module Main ( main ) where
  
  import Control.Monad
  import Data.Bifunctor  ( bimap )
  import Data.Char       ( isSpace )
  import Data.Foldable
  import Data.Functor
  import Data.List       ( partition )
  import Data.Maybe
  import Data.Text ( Text )
  import qualified Data.Text as Text
  import qualified Data.ByteString.Char8 as BS
  
  import Data.Set (Set)
  import qualified Data.Set as Set
  
  import qualified Data.Vector as V
  
  import System.Environment ( getArgs, getEnv, getProgName )
  import System.Exit        ( die )
  import System.IO          ( hPutStrLn, stderr )
  
  import GitHub.Auth
    ( Auth( OAuth )
    )
  import GitHub.Data.Definitions
    ( IssueLabel ( labelName )
    , unIssueNumber
    )
  import GitHub.Data.Issues
    ( Issue( Issue
           , issueLabels
           , issueMilestone
           , issueNumber
           , issuePullRequest
           , issueStateReason
           , issueTitle
           )
    )
  import GitHub.Data.Id
    ( Id
    )
  import GitHub.Data.Name
    ( Name( N )
    , untagName
    )
  import GitHub.Data.Milestone
    ( Milestone( milestoneNumber, milestoneTitle )
    )
  import GitHub.Data.Options
    ( optionsMilestone
    , stateClosed
    , IssueStateReason( StateReasonNotPlanned )
    )
  import GitHub.Data.Request
    ( FetchCount(FetchAll)
    )
  import GitHub.Endpoints.Issues.Milestones
    ( milestonesR
    )
  import GitHub.Endpoints.Issues
    ( issuesForRepoR
    )
  import GitHub.Endpoints.PullRequests
    ( isPullRequestMergedR
    )
  import GitHub.Request
    ( github
    )
  
  envGHToken :: String
  envGHToken = "GITHUB_TOKEN"
  
  owner, repo :: Text
  owner = "agda"
  repo  = "agda"
  
  theRepo :: String
  theRepo = Text.unpack owner ++ "/" ++ Text.unpack repo
  
  main :: IO ()
  main = getArgs >>= \case
    "-h"     : _ -> usage
    "--help" : _ -> usage
    [arg]        -> run (Text.pack arg)
    _            -> usage
  
  usage :: IO ()
  usage = do
    progName <- getProgName
    putStrLn $ unlines
      [ "Usage: " ++ progName ++ " <milestone>"
      , ""
      , "Retrieves closed issues for the given milestone from github repository"
      , theRepo ++ " and prints them as markdown to stdout."
      , ""
      , "Expects an access token in environment variable GITHUB_TOKEN."
      ]
  
  debugPrint :: String -> IO ()
  debugPrint = hPutStrLn stderr
  
  type Label = Text
  
  issueLabelsNames :: Issue -> [Label]
  issueLabelsNames i = map (untagName . labelName) $ V.toList $ issueLabels i
  
  -- Please keep the labels in the list in alphabetic order!
  labelsNotInChangelog :: Set Label
  labelsNotInChangelog = Set.fromList
    [ "Makefile"
    , "agda-bisect"
    , "bug-tracker"
    , "closed-issues-for-milestone"
    , "debug"
    , "dev: hlint"
    , "devx"
    , "documented-in-changelog"
    , "faq"
    , "fix-agda-whitespace"
    , "haddock"
    , "hTags"
    , "infra: github workflows"
    , "infra: test suite"
    , "maculata"
    , "not-in-changelog"
    , "refactor"
    , "regression on master"
    , "release"
    , "repository"
    , "status: abandoned"
    , "status: duplicate"
    , "status: invalid"
    , "status: wontfix"
    , "status: working-as-intended"
    , "style"
    , "travis"
    , "type: question"
    , "type: task"
    , "typo"
    ]
  
  -- | Classification of issues.
  --
  -- We filter issues by the following criteria:
  -- 1. Correct milestone or wrong milestone (the latter should be impossible).
  -- 2. Issue or PR.
  -- 3. Happened (regular close or merge) or didn't happen (close as not planned or closed without merge).
  -- 4. Should be listed or not (in the latter case, give the labels that indicate it should not be listed).
  
  data Class = Class
    { correctMilestone :: Bool       -- ^ False if milestone is not the one we requested.
    , isIssue          :: Bool       -- ^ False if PR.
    , happened         :: Bool       -- ^ False if closed as not planned or closed without merge.
    , goodLabels       :: Set Label  -- ^ Labels that do not affect inclusion in changelog.
    , badLabels        :: Set Label  -- ^ Labels that prevent inclusion in changelog
    }
  
  -- | Issue enriched with its classification.
  --
  data ClassifiedIssue = ClassifiedIssue
    { theIssue   :: Issue
    , issueClass :: Class
    }
  
  -- | This classifies issue numbers,
  --   but the field 'happened' is only set correctly for issues, not for milestones.
  --
  classifyIssue :: Id Milestone -> Issue -> Class
  classifyIssue mileStoneId i = Class{..}
    where
    correctMilestone        = maybe False ((mileStoneId ==) . milestoneNumber) $ issueMilestone i
    isIssue                 = isNothing $ issuePullRequest i
    happened                = maybe True (StateReasonNotPlanned /=) $ issueStateReason i
    (badLabels, goodLabels) = bimap Set.fromList Set.fromList $
       partition (`Set.member` labelsNotInChangelog) $ issueLabelsNames i
  
  -- | Delete trailing whitespace from issue
  sanitizeIssue :: Issue -> Issue
  sanitizeIssue i = i{ issueTitle = trim $ issueTitle i }
    where
      trim = Text.dropWhileEnd isSpace
  
  -- | Format issue in markdown for printing.
  --
  printIssue :: Issue -> String
  printIssue Issue{ issueNumber, issueTitle, issuePullRequest } = do
    let n = show $ unIssueNumber issueNumber
    let issuePR = if isNothing issuePullRequest then "Issue" else "PR"
    concat
      [ "[", issuePR, " #", n, "]"
      , "(https://github.com/", theRepo, "/issues/", n, ")"
      , ": ", Text.unpack issueTitle
      ]
  
  debugPrintIssues :: [ClassifiedIssue] -> String -> IO ()
  debugPrintIssues is title =
    unless (null is) do
      debugPrint title
      forM_ is $ \ (ClassifiedIssue i _c) -> debugPrint $ "- " ++ printIssue i
      debugPrint ""
  
  
  -- | Retrieve closed issues for the given milestone and print as csv to stdout.
  run :: Text -> IO ()
  run mileStoneTitle = do
  
    -- Get authentication token from environment.
    auth <- OAuth . BS.pack <$> getEnv envGHToken
  
    -- Log in to repo.
  
    debugPrint $ "Getting milestone " ++ Text.unpack mileStoneTitle
  
    -- Resolve milestone into milestone id.
    mileStoneVector <- crashOr $ github auth $ milestonesR (N owner) (N repo) FetchAll
    mileStoneId <- case filter ((mileStoneTitle ==) . milestoneTitle) $ toList mileStoneVector of
      []  -> die $ "Milestone " ++ Text.unpack mileStoneTitle ++ " not found in github repo " ++ theRepo
      [m] -> return $ milestoneNumber m
      _   -> die $ "Milestone " ++ Text.unpack mileStoneTitle ++ " ambiguous in github repo " ++ theRepo
  
    -- Debug.
    debugPrint $ "Getting issues for milestone number " ++ show mileStoneId
  
    let issueFilter = optionsMilestone mileStoneId <> stateClosed
    -- Get list of issues. GitHub's REST API v3 considers every pull
    -- request an issue. For this reason we get a list of both issues
    -- and pull requests when using the function 'issuesForRepo''.
    issueVector <- crashOr $ github auth $ issuesForRepoR (N owner) (N repo) issueFilter FetchAll
  
    -- Classify issues and remove trailing whitespace from the issue title.
    let issues0 :: [ClassifiedIssue]
        issues0 = reverse (toList issueVector) <&> \ i ->
          ClassifiedIssue (sanitizeIssue i) (classifyIssue mileStoneId i)
  
    -- We progressively filter out issue numbers not included in changelog.
  
    -- Filter out issues/PRs with wrong milestone:
    let (issues1, wrongMilestone) = partition (correctMilestone . issueClass) issues0
    debugPrintIssues wrongMilestone "Issues/PR with wrong milestone:"
  
    -- Filter out issues that were "Closed as not planned"
    let (issues2, didNotHappen) = partition (happened . issueClass) issues1
    debugPrintIssues didNotHappen "Issues closed as not planned"
  
    -- Find out which PRs were closed without merging
    issues3 <- forM issues2 $ \ ic@(ClassifiedIssue i c) -> do
      if isIssue c then pure ic else do
        merged <- crashOr $ github auth $ isPullRequestMergedR (N owner) (N repo) (issueNumber i)
        pure (ClassifiedIssue i c{ happened = merged })
  
    -- Filter out PRs that were closed without merging
    let (issues4, notMerged) = partition (happened . issueClass) issues3
    debugPrintIssues notMerged "PRs closed without merging"
  
    -- Filter out issues/PRs that have a bad label
    let (issues5, badLabel)  = partition (Set.null . badLabels . issueClass) issues4
    debugPrintIssues badLabel "Issues/PRs that have a label excluding them from the changelog"
  
    -- Print issues and PRs.
  
    let ms = Text.unpack mileStoneTitle
    if null issues5 then debugPrint $
      "No matching closed issues or PRs in milestone " ++ ms
    else do
      let (issues, prs) = partition (isIssue . issueClass) issues5
      debugPrintIssues issues $ "Issues for closed for milestone " ++ ms
      debugPrintIssues prs $ "PRs for closed for milestone " ++ ms
      forM_ issues $ \ ic -> putStrLn $ "- " ++ printIssue (theIssue ic)
      forM_ prs    $ \ ic -> putStrLn $ "- " ++ printIssue (theIssue ic)
  
  
  -- | Crash on exception.
  crashOr :: Show e => IO (Either e a) -> IO a
  crashOr m = either (die . show) return =<< m
  