Finish implementing the changelog generator.

.gitignore

@@ -1,2 +1,3 @@
 /cabal.sandbox.config
 /dist
+/.stack-work

Makefile

@@ -10,5 +10,5 @@ dist/build/changelog/changelog: dist/build/pull-status/pull-status
 dist/build/pull-status/pull-status: dist/setup-config $(shell find src -type f)
 	cabal build
 
-dist/setup-config: pull-status.cabal
+dist/setup-config: $(wildcard *.cabal)
 	cabal configure

pull-status.cabal → github-tools.cabal

@@ -1,7 +1,6 @@
-name:                pull-status
+name:                github-tools
 version:             0.1.0
-synopsis:            Github Pull Request status tool
-description:         Github Pull Request status tool
+synopsis:            Various Github helper utilities.
 homepage:            https://toktok.github.io/
 license:             AGPL-3
 license-file:        LICENSE
@@ -10,23 +9,30 @@ maintainer:          iphydf@users.noreply.github.com
 category:            Development
 build-type:          Simple
 cabal-version:       >=1.10
+description:
+  - Pull Request status tool.
+  - Change log generator.
 
 source-repository head
   type:             git
   location:         https://github.com/TokTok/pull-status.git
 
 executable pull-status
   main-is:             pull-status.hs
+  other-modules:
+      PullRequestInfo
+      Requests
+      Review
   ghc-options:
       -Wall
   build-depends:
       base >= 4 && < 5
     , bytestring
     , exceptions
-    , github          >= 0.15.0
+    , github            >= 0.15.0
     , groom
     , html
-    , http-client
+    , http-client       >= 0.4.30
     , http-client-tls
     , monad-parallel
     , tabular
@@ -39,14 +45,16 @@ executable pull-status
 
 executable changelog
   main-is:             changelog.hs
+  other-modules:
+      Requests
   ghc-options:
       -Wall
   build-depends:
       base >= 4 && < 5
     , bytestring
     , containers
     , exceptions
-    , github          >= 0.15.0
+    , github            >= 0.15.0
     , groom
     , http-client
     , http-client-tls

src/Review.hs

@@ -10,7 +10,8 @@ import           Data.Text.Encoding     (decodeUtf8)
 import qualified GitHub
 import           Network.HTTP.Client    (Manager, httpLbs, parseRequest,
                                          responseBody)
-import           Text.HTML.TagSoup.Tree (TagTree (..), parseTree)
+import           Text.HTML.TagSoup      (parseTags)
+import           Text.HTML.TagSoup.Tree (TagTree (..), tagTree)
 
 
 data Approval
@@ -64,6 +65,7 @@ approvalsFromHtml statuses =
   . extractApprovals statuses
   . collectDiscussionItems
   . TagBranch "xml" []
-  . parseTree
+  . tagTree
+  . parseTags
   where
     nubWith f = List.nubBy (\x y -> f x == f y)

src/changelog.hs

@@ -2,75 +2,158 @@
 {-# LANGUAGE OverloadedStrings #-}
 module Main (main) where
 
-import           Control.Applicative     ((<$>))
+import           Control.Applicative     ((<$>), (<*>))
+import           Control.Arrow           (first, second, (&&&))
 import qualified Data.ByteString.Char8   as BS8
+import           Data.List               (foldl')
 import qualified Data.Map                as Map
 import qualified Data.Maybe              as Maybe
 import           Data.Monoid             ((<>))
+import           Data.String             (fromString)
+import           Data.Text               (Text)
 import qualified Data.Text               as Text
 import qualified Data.Vector             as V
 import qualified GitHub
 import           Network.HTTP.Client     (newManager)
 import           Network.HTTP.Client.TLS (tlsManagerSettings)
-import           System.Environment      (getEnv)
-import           Text.Groom              (groom)
+import           System.Environment      (getArgs, getEnv)
+-- import           Text.Groom              (groom)
 
 import           Requests
 
 
-type ChangeLog = [(String, [String])]
+type ChangeLog = [(Text, [Text], [Text])]
 
 
-formatChangeLog :: ChangeLog -> String
-formatChangeLog = groom
+formatChangeLog :: Text -> ChangeLog -> Text
+formatChangeLog name = (<> "\n") . foldl' (<>) ("# Changelog for " <> name) . map formatMilestone
+  where
+    formatMilestone (milestone, issues, pulls) =
+      "\n\n## " <> milestone
+      <> closedIssues issues
+      <> mergedPrs pulls
+
+    closedIssues [] = ""
+    closedIssues issues =
+      foldl' (<>) "\n\n### Closed issues:\n" . itemise $ issues
+
+    mergedPrs [] = ""
+    mergedPrs pulls =
+      foldl' (<>) "\n\n### Merged PRs:\n" . itemise $ pulls
+
+    itemise = map ("\n- " <>)
+
+
+data ChangeLogItemKind
+  = PullRequest
+  | Issue
+  deriving Show
 
 
-formatIssue :: GitHub.Issue -> String
-formatIssue issue =
-  "#" ++ show (GitHub.issueNumber issue) ++ " " ++ Text.unpack (GitHub.issueTitle issue)
+data ChangeLogItem = ChangeLogItem
+  { clMilestone :: Text
+  , clTitle     :: Text
+  , clNumber    :: Int
+  }
 
 
-makeChangeLog :: [GitHub.Issue] -> String
-makeChangeLog issues = formatChangeLog changeLog
+formatChangeLogItem :: GitHub.Name GitHub.Owner -> GitHub.Name GitHub.Repo -> ChangeLogItem -> Text
+formatChangeLogItem ownerName repoName item =
+  "[#" <> number <> "](https://github.com/" <> GitHub.untagName ownerName <> "/" <> GitHub.untagName repoName <> "/issues/" <> number <> ") " <> clTitle item
   where
-    relevantIssues = filter (\case
+    number = Text.pack . show . clNumber $ item
+
+
+makeChangeLog :: GitHub.Name GitHub.Owner -> GitHub.Name GitHub.Repo -> [GitHub.SimplePullRequest] -> [GitHub.Issue] -> ChangeLog
+makeChangeLog ownerName repoName pulls issues =
+  Map.foldlWithKey (\changes milestone (msIssues, msPulls) ->
+      ( milestone
+      , map (formatChangeLogItem ownerName repoName) msIssues
+      , map (formatChangeLogItem ownerName repoName) msPulls
+      ) : changes
+    ) []
+  . groupByMilestone (first  . (:)) changeLogIssues
+  . groupByMilestone (second . (:)) changeLogPrs
+  $ Map.empty
+  where
+    mergedPrs = filter (\case
+        GitHub.SimplePullRequest
+          { GitHub.simplePullRequestMergedAt = Just _
+          } -> True
+        _ -> False
+      ) pulls
+
+    closedItems = filter (\case
         GitHub.Issue
           { GitHub.issueMilestone = Just GitHub.Milestone
             { GitHub.milestoneState = "closed" }
           } -> True
         _ -> False
       ) issues
 
-    issuesByMilestone = foldl (\byMilestone issue ->
-        let
-          milestone = GitHub.milestoneTitle . Maybe.fromJust . GitHub.issueMilestone $ issue
-          msIssues =
-            case Map.lookup milestone byMilestone of
-              Just old -> issue : old
-              Nothing  -> [issue]
-        in
-        Map.insert milestone msIssues byMilestone
-      ) Map.empty relevantIssues
-
-    changeLog = Map.foldlWithKey (\changes milestone msIssues ->
-        (Text.unpack milestone, map formatIssue msIssues) : changes
-      ) [] issuesByMilestone
-
-
-main :: IO ()
-main = do
-  let ownerName = "TokTok"
-  let repoName = "c-toxcore"
-
+    milestoneByIssueId =
+      Map.fromList
+      . map (GitHub.issueNumber &&& GitHub.milestoneTitle . Maybe.fromJust . GitHub.issueMilestone)
+      $ closedItems
+
+    changeLogIssues :: [ChangeLogItem]
+    changeLogIssues = Maybe.mapMaybe (\case
+        -- filter out PRs
+        GitHub.Issue { GitHub.issuePullRequest = Just _ } -> Nothing
+        issue -> Just $ ChangeLogItem
+          { clMilestone = GitHub.milestoneTitle . Maybe.fromJust . GitHub.issueMilestone $ issue
+          , clTitle     = GitHub.issueTitle issue
+          , clNumber    = GitHub.issueNumber issue
+          }
+      ) closedItems
+
+    changeLogPrs :: [ChangeLogItem]
+    changeLogPrs = Maybe.mapMaybe (\issue -> do
+        milestone <- flip Map.lookup milestoneByIssueId . GitHub.simplePullRequestNumber $ issue
+        return $ ChangeLogItem
+          { clMilestone = milestone
+          , clTitle     = GitHub.simplePullRequestTitle issue
+          , clNumber    = GitHub.simplePullRequestNumber issue
+          }
+      ) mergedPrs
+
+    groupByMilestone add = flip $ foldr (\item group ->
+        Map.insert (clMilestone item) (
+            case Map.lookup (clMilestone item) group of
+              Just old -> add item old
+              Nothing  -> add item ([], [])
+          ) group
+      )
+
+
+fetchChangeLog :: GitHub.Name GitHub.Owner -> GitHub.Name GitHub.Repo -> IO ChangeLog
+fetchChangeLog ownerName repoName = do
   -- Get auth token from the $GITHUB_TOKEN environment variable.
   token <- BS8.pack <$> getEnv "GITHUB_TOKEN"
   let auth = GitHub.OAuth token
 
   -- Initialise HTTP manager so we can benefit from keep-alive connections.
   mgr <- newManager tlsManagerSettings
 
-  issues <- V.toList <$> request auth mgr (GitHub.issuesForRepoR ownerName repoName (GitHub.stateClosed <> GitHub.optionsAnyMilestone) GitHub.FetchAll)
+  let pulls  = V.toList <$> request auth mgr (GitHub.pullRequestsForR ownerName repoName GitHub.stateClosed GitHub.FetchAll)
+  let issues = V.toList <$> request auth mgr (GitHub.issuesForRepoR   ownerName repoName (GitHub.stateClosed <> GitHub.optionsAnyMilestone) GitHub.FetchAll)
+
+  -- issues >>= putStrLn . groom
+
+  makeChangeLog ownerName repoName <$> pulls <*> issues
 
-  putStrLn $ makeChangeLog issues
 
-  return ()
+main :: IO ()
+main = do
+  (ownerName, repoName) <- getArgs >>= repoLocation
+  let name = (GitHub.untagName ownerName) <> "/" <> (GitHub.untagName repoName)
+
+  fetchChangeLog ownerName repoName >>= putStr . Text.unpack . formatChangeLog name
+
+  where
+    repoLocation [] =
+      return ("TokTok", "c-toxcore")
+    repoLocation [ownerName, repoName] =
+      return (fromString ownerName, fromString repoName)
+    repoLocation _ =
+      fail "Usage: changelog <owner> <repo>"