[ cifm ] Pimp closed-issues-for-milestone: now includes PRs

Also prints filtered-out issues with the reason for filtering them out.

src/release-tools/closed-issues-for-milestone/Main.hs

@@ -1,17 +1,25 @@
+{-# 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.Foldable
--- import Data.List ( intercalate )
+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 )
@@ -35,6 +43,9 @@ import GitHub.Data.Issues
          , issueTitle
          )
   )
+import GitHub.Data.Id
+  ( Id
+  )
 import GitHub.Data.Name
   ( Name( N )
   , untagName
@@ -56,6 +67,9 @@ import GitHub.Endpoints.Issues.Milestones
 import GitHub.Endpoints.Issues
   ( issuesForRepoR
   )
+import GitHub.Endpoints.PullRequests
+  ( isPullRequestMergedR
+  )
 import GitHub.Request
   ( github
   )
@@ -92,12 +106,14 @@ usage = do
 debugPrint :: String -> IO ()
 debugPrint = hPutStrLn stderr
 
-issueLabelsNames :: Issue -> [Text]
+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 :: [Text]
-labelsNotInChangelog =
+labelsNotInChangelog :: Set Label
+labelsNotInChangelog = Set.fromList
   [ "Makefile"
   , "agda-bisect"
   , "bug-tracker"
@@ -129,6 +145,54 @@ labelsNotInChangelog =
   , "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
+  }
+
+-- | 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
+
+-- | 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 :: [(Issue,Class)] -> String -> IO ()
+debugPrintIssues is title =
+  unless (null is) do
+    debugPrint title
+    forM_ is $ \ (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
@@ -156,45 +220,46 @@ run mileStoneTitle = do
   -- and pull requests when using the function 'issuesForRepo''.
   issueVector <- crashOr $ github auth $ issuesForRepoR (N owner) (N repo) issueFilter FetchAll
 
-  -- Filter by issues, milestone, reason for closure, and labels.
-  let issues :: [Issue]
-      issues = reverse
-        [ i
-        | i <- toList issueVector
-
-        -- Filter out PRs
-        , isNothing $ issuePullRequest i
-
-        -- Filter out "Closed as not planned"
-        , maybe True (StateReasonNotPlanned /=) $ issueStateReason i
-
-        -- Filter out wrong milestones
-        , m <- maybeToList $ issueMilestone i
-        , milestoneNumber m == mileStoneId
-
-        -- Filter out "not in changelog" issues
-        , not $ any (`elem` issueLabelsNames i) labelsNotInChangelog
-        ]
-
-  debugPrint $ unwords
-    [ "Found", show (length issues), "closed issues tagged with milestone", Text.unpack mileStoneTitle ]
-
-  -- Print issues.
-
-  forM_ issues $ \ Issue{ issueNumber, issueTitle } -> do
-    let n = unIssueNumber issueNumber
-    putStrLn $
-      "- [#" ++ show n
-     ++ "](https://github.com/" ++ theRepo ++ "/issues/" ++ show n
-     ++ "): " ++ Text.unpack issueTitle
-
-  -- TODO: output tsv
-  --
-  -- forM_ issues $ \ Issue{ issueNumber, issueTitle } -> do
-  --   putStrLn $ intercalate "\t" $
-  --     [ show issueNumber
-  --     , Text.unpack issueTitle
-  --     ]
+  -- Classify issues.
+  let issues0 :: [(Issue, Class)]
+      issues0 = reverse (toList issueVector) <&> \ i -> (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 . snd) issues0
+  debugPrintIssues wrongMilestone "Issues/PR with wrong milestone:"
+
+  -- Filter out issues that were "Closed as not planned"
+  let (issues2, didNotHappen) = partition (happened . snd) issues1
+  debugPrintIssues didNotHappen "Issues closed as not planned"
+
+  -- Find out which PRs were closed without merging
+  issues3 <- forM issues2 $ \ ic@(i, c) -> do
+    if isIssue c then pure ic else do
+      merged <- crashOr $ github auth $ isPullRequestMergedR (N owner) (N repo) (issueNumber i)
+      pure (i, c { happened = merged })
+
+  -- Filter out PRs that were closed without merging
+  let (issues4, notMerged) = partition (happened . snd) issues3
+  debugPrintIssues notMerged "PRs closed without merging"
+
+  -- Filter out issues/PRs that have a bad label
+  let (issues5, badLabel)  = partition (Set.null . badLabels . snd) 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 . snd) issues5
+    debugPrintIssues issues $ "Issues for closed for milestone " ++ ms
+    debugPrintIssues prs $ "PRs for closed for milestone " ++ ms
+    forM_ issues $ \ ic -> putStrLn $ "- " ++ printIssue (fst ic)
+    forM_ prs    $ \ ic -> putStrLn $ "- " ++ printIssue (fst ic)
+
 
 -- | Crash on exception.
 crashOr :: Show e => IO (Either e a) -> IO a

src/release-tools/closed-issues-for-milestone/closed-issues-for-milestone.cabal

@@ -1,5 +1,5 @@
 name:                closed-issues-for-milestone
-version:             0.1.0.0
+version:             0.2
 synopsis:            Report the closed issues in GitHub for milestone.
 -- description:
 -- license:             LICENSE
@@ -26,6 +26,7 @@ executable closed-issues-for-milestone
 
   build-depends:  base       >= 4.13.0.0  && < 4.20
                 , bytestring >= 0.10.9.0  && < 0.13
+                , containers >= 0.6.0.1   && < 0.8
                 , github     >= 0.29      && < 0.30
                 , text       >= 1.2.3     && < 2.2
                 , vector     >= 0.12.0.3  && < 0.14

src/release-tools/closed-issues-for-milestone/stack-9.2.8.yaml

@@ -1,3 +1,6 @@
 resolver: lts-20.26
 compiler: ghc-9.2.8
 compiler-check: match-exact
+
+extra-deps:
+- github-0.29

src/release-tools/closed-issues-for-milestone/stack-9.4.8.yaml

@@ -1,3 +1,6 @@
 resolver: lts-21.25
 compiler: ghc-9.4.8
 compiler-check: match-exact
+
+extra-deps:
+- github-0.29