fix: Sort milestone versions correctly in changelog/roadmap.

BUILD.bazel

@@ -28,6 +28,7 @@ haskell_library(
         hazel_library("http-client-tls"),
         hazel_library("monad-parallel"),
         hazel_library("quickcheck-text"),
+        hazel_library("split"),
         hazel_library("tabular"),
         hazel_library("text"),
         hazel_library("time"),

README.md

@@ -1,3 +1,5 @@
 # Github tools for TokTok projects
 
-See https://git-critique.herokuapp.com/hello/pulls.html.
+c-toxcore pull requests: https://git-critique.herokuapp.com/hello/pulls.html.
+
+c-toxcore roadmap requests: https://git-critique.herokuapp.com/hello/roadmap.html.

github-tools.cabal

@@ -125,6 +125,7 @@ library
     , monad-parallel
     , QuickCheck
     , quickcheck-text
+    , split
     , tabular
     , text
     , time

src/Changelogs.hs

@@ -8,16 +8,20 @@ module Changelogs
   ) where
 
 import           Control.Arrow           (first, second, (&&&))
+import qualified Control.Monad.Parallel  as P
 import           Data.List               (foldl')
 import qualified Data.List               as List
+import qualified Data.List.Split         as List
 import qualified Data.Map                as Map
 import qualified Data.Maybe              as Maybe
 import           Data.Text               (Text)
 import qualified Data.Text               as Text
 import qualified Data.Vector             as V
+import           Debug.Trace             (traceIO)
 import qualified GitHub
 import           Network.HTTP.Client     (newManager)
 import           Network.HTTP.Client.TLS (tlsManagerSettings)
+import           Text.Read               (readMaybe)
 -- import           Text.Groom              (groom)
 
 import           Requests
@@ -26,6 +30,23 @@ import           Requests
 newtype ChangeLog = ChangeLog { unChangeLog :: [(Text, [Text], [Text])] }
 
 
+data VersionComponent
+  = Number Int
+  | Wildcard
+  deriving (Ord, Eq)
+
+
+instance Read VersionComponent where
+  readsPrec _ ('x':s) = [(Wildcard, s)]
+  readsPrec p input   = map (first Number) . readsPrec p $ input
+
+
+data Version
+  = VersionNumber [VersionComponent]
+  | VersionString Text
+  deriving (Ord, Eq)
+
+
 formatChangeLog :: Bool -> ChangeLog -> Text
 formatChangeLog wantRoadmap =
   (<> "\n") . foldl' (<>) "" . map formatMilestone . unChangeLog
@@ -72,8 +93,7 @@ groupByMilestone add = flip $ foldr (\item group ->
         case Map.lookup (clMilestone item) group of
           Just old -> add item old
           Nothing  -> add item ([], [])
-      ) group
-  )
+      ) group)
 
 
 formatChangeLogItem
@@ -103,6 +123,7 @@ makeChangeLog
   -> ChangeLog
 makeChangeLog wantRoadmap ownerName repoName pulls issues =
   ChangeLog
+  . reverseIfChangelog
   . sortChangelog
   . Map.foldlWithKey (\changes milestone (msIssues, msPulls) ->
       if milestone == "meta"
@@ -117,12 +138,25 @@ makeChangeLog wantRoadmap ownerName repoName pulls issues =
   . groupByMilestone (second . (:)) changeLogPrs
   $ Map.empty
   where
-    sortChangelog l =
+    reverseIfChangelog l =
       if wantRoadmap
-        then case reverse l of
+        then l
+        else case reverse l of
           []   -> []
           x:xs -> xs ++ [x] -- Put "Backlog" last.
-        else l
+
+    sortChangelog :: [(Text, [Text], [Text])] -> [(Text, [Text], [Text])]
+    sortChangelog = List.sortOn $ \(v, _, _) -> parseVersion v
+
+    parseVersion :: Text -> Version
+    parseVersion v =
+        case Text.unpack v of
+            -- Milestones starting with "v" must be versions.
+            'v':version ->
+                case map readMaybe $ List.splitOn "." version of
+                  [Just major, Just minor, Just rev] -> VersionNumber [major, minor, rev]
+                  _ -> error $ "invalid version: " <> version
+            _ -> VersionString v
 
     (mergedPrs, openPrs) = List.partition (\case
         GitHub.SimplePullRequest
@@ -210,11 +244,23 @@ fetchChangeLog wantRoadmap ownerName repoName auth = do
   -- Initialise HTTP manager so we can benefit from keep-alive connections.
   mgr <- newManager tlsManagerSettings
 
-  let pulls  state = V.toList <$> request auth mgr (GitHub.pullRequestsForR ownerName repoName state GitHub.FetchAll)
-  let issues state = V.toList <$> request auth mgr (GitHub.issuesForRepoR   ownerName repoName state GitHub.FetchAll)
+  let fetchPulls state = do
+          traceIO $ "Fetching pull requests"
+          l <- V.toList <$> request auth mgr (GitHub.pullRequestsForR ownerName repoName state GitHub.FetchAll)
+          traceIO $ "Got " <> show (length l) <> " pull requests"
+          return l
+  let fetchIssues state = do
+          traceIO $ "Fetching issues"
+          l <- V.toList <$> request auth mgr (GitHub.issuesForRepoR   ownerName repoName state GitHub.FetchAll)
+          traceIO $ "Got " <> show (length l) <> " issues"
+          return l
 
   -- issues >>= putStrLn . groom
 
-  if wantRoadmap
-    then makeChangeLog wantRoadmap ownerName repoName <$> pulls GitHub.stateOpen   <*> issues GitHub.stateOpen
-    else makeChangeLog wantRoadmap ownerName repoName <$> pulls GitHub.stateClosed <*> issues GitHub.stateClosed
+  (pulls, issues) <- uncurry (P.bindM2 (\p i -> return (p, i))) $
+          if wantRoadmap
+             then (fetchPulls GitHub.stateOpen  , fetchIssues GitHub.stateOpen  )
+             else (fetchPulls GitHub.stateClosed, fetchIssues GitHub.stateClosed)
+
+  traceIO "Formatting changelog/roadmap"
+  return $ makeChangeLog wantRoadmap ownerName repoName pulls issues

tools/BUILD.bazel

@@ -0,0 +1,28 @@
+load("@ai_formation_hazel//tools:mangling.bzl", "hazel_library")
+load("@rules_haskell//haskell:defs.bzl", "haskell_binary")
+
+haskell_binary(
+    name = "hub-changelog",
+    srcs = ["hub-changelog.hs"],
+    visibility = ["//visibility:public"],
+    deps = [
+        "//hs-github-tools",
+        hazel_library("base"),
+        hazel_library("bytestring"),
+        hazel_library("github"),
+        hazel_library("text"),
+    ],
+)
+
+haskell_binary(
+    name = "hub-roadmap",
+    srcs = ["hub-roadmap.hs"],
+    visibility = ["//visibility:public"],
+    deps = [
+        "//hs-github-tools",
+        hazel_library("base"),
+        hazel_library("bytestring"),
+        hazel_library("github"),
+        hazel_library("text"),
+    ],
+)

tools/hub-changelog.hs

@@ -1,7 +1,6 @@
 {-# LANGUAGE OverloadedStrings #-}
 module Main (main) where
 
-import           Control.Applicative   ((<$>))
 import qualified Data.ByteString.Char8 as BS8
 import           Data.String           (fromString)
 import qualified Data.Text             as Text
@@ -26,4 +25,4 @@ main = do
     repoLocation [ownerName, repoName] =
       return (fromString ownerName, fromString repoName)
     repoLocation _ =
-      fail "Usage: changelog <owner> <repo>"
+      fail "Usage: hub-changelog <owner> <repo>"

tools/hub-roadmap.hs

@@ -1,7 +1,6 @@
 {-# LANGUAGE OverloadedStrings #-}
 module Main (main) where
 
-import           Control.Applicative   ((<$>))
 import qualified Data.ByteString.Char8 as BS8
 import           Data.String           (fromString)
 import qualified Data.Text             as Text
@@ -26,4 +25,4 @@ main = do
     repoLocation [ownerName, repoName] =
       return (fromString ownerName, fromString repoName)
     repoLocation _ =
-      fail "Usage: changelog <owner> <repo>"
+      fail "Usage: hub-roadmap <owner> <repo>"