haskellPackages: add newtype for PkgName and PkgSet in hydra-report.hs
Add a newtype for a package name and a package set. This is less for correctness, and more just to make the code a little easier to read through without having to keep in mind what each Text refers to.
This commit is contained in:
Dennis Gosnell
parent
b2af201c0e
commit
19b5676361
1 changed files with 180 additions and 41 deletions
|
|
@ -262,7 +262,7 @@ type MaintainerMap = Map JobName (NonEmpty Text)
|
|||
-- | Information about a package which lists its dependencies and whether the
|
||||
-- package is marked broken.
|
||||
data DepInfo = DepInfo {
|
||||
deps :: Set Text,
|
||||
deps :: Set PkgName,
|
||||
broken :: Bool
|
||||
}
|
||||
deriving stock (Generic, Show)
|
||||
|
|
@ -270,23 +270,37 @@ data DepInfo = DepInfo {
|
|||
|
||||
-- | Map from package names to their DepInfo. This is the data we get out of a
|
||||
-- nix call.
|
||||
type DependencyMap = Map Text DepInfo
|
||||
type DependencyMap = Map PkgName DepInfo
|
||||
|
||||
-- | Map from package names to its broken state, number of reverse dependencies (fst) and
|
||||
-- unbroken reverse dependencies (snd).
|
||||
type ReverseDependencyMap = Map Text (Int, Int)
|
||||
type ReverseDependencyMap = Map PkgName (Int, Int)
|
||||
|
||||
-- | Calculate the (unbroken) reverse dependencies of a package by transitively
|
||||
-- going through all packages if it’s a dependency of them.
|
||||
calculateReverseDependencies :: DependencyMap -> ReverseDependencyMap
|
||||
calculateReverseDependencies depMap = Map.fromDistinctAscList $ zip keys (zip (rdepMap False) (rdepMap True))
|
||||
calculateReverseDependencies depMap =
|
||||
Map.fromDistinctAscList $ zip keys (zip (rdepMap False) (rdepMap True))
|
||||
where
|
||||
-- This code tries to efficiently invert the dependency map and calculate
|
||||
-- it’s transitive closure by internally identifying every pkg with it’s index
|
||||
-- in the package list and then using memoization.
|
||||
keys :: [PkgName]
|
||||
keys = Map.keys depMap
|
||||
|
||||
pkgToIndexMap :: Map PkgName Int
|
||||
pkgToIndexMap = Map.fromDistinctAscList (zip keys [0..])
|
||||
intDeps = zip [0..] $ (\DepInfo{broken,deps} -> (broken,mapMaybe (`Map.lookup` pkgToIndexMap) $ Set.toList deps)) <$> Map.elems depMap
|
||||
|
||||
depInfos :: [DepInfo]
|
||||
depInfos = Map.elems depMap
|
||||
|
||||
depInfoToIdx :: DepInfo -> (Bool, [Int])
|
||||
depInfoToIdx DepInfo{broken,deps} =
|
||||
(broken, mapMaybe (`Map.lookup` pkgToIndexMap) $ Set.toList deps)
|
||||
|
||||
intDeps :: [(Int, (Bool, [Int]))]
|
||||
intDeps = zip [0..] (fmap depInfoToIdx depInfos)
|
||||
|
||||
rdepMap onlyUnbroken = IntSet.size <$> resultList
|
||||
where
|
||||
resultList = go <$> [0..]
|
||||
|
|
@ -315,7 +329,10 @@ getMaintainerMap = do
|
|||
-- script ./dependencies.nix.
|
||||
getDependencyMap :: IO DependencyMap
|
||||
getDependencyMap =
|
||||
readJSONProcess nixExprCommand ("maintainers/scripts/haskell/dependencies.nix":nixExprParams) "Failed to decode nix output for lookup of dependencies: "
|
||||
readJSONProcess
|
||||
nixExprCommand
|
||||
("maintainers/scripts/haskell/dependencies.nix" : nixExprParams)
|
||||
"Failed to decode nix output for lookup of dependencies: "
|
||||
|
||||
-- | Run a process that produces JSON on stdout and and decode the JSON to a
|
||||
-- data type.
|
||||
|
|
@ -367,15 +384,52 @@ platformIcon (Platform x) = case x of
|
|||
"aarch64-darwin" -> ":green_apple:"
|
||||
_ -> x
|
||||
|
||||
-- | A package name. This is parsed from a 'JobName'.
|
||||
--
|
||||
-- Examples:
|
||||
--
|
||||
-- - The 'JobName' @"haskellPackages.lens.x86_64-linux"@ produces the 'PkgName'
|
||||
-- @"lens"@.
|
||||
-- - The 'JobName' @"haskell.packages.ghc925.cabal-install.aarch64-darwin"@
|
||||
-- produces the 'PkgName' @"cabal-install"@.
|
||||
-- - The 'JobName' @"pkgsMusl.haskell.compiler.ghc90.x86_64-linux"@ produces
|
||||
-- the 'PkgName' @"ghc90"@.
|
||||
-- - The 'JobName' @"arion.aarch64-linux"@ produces the 'PkgName' @"arion"@.
|
||||
--
|
||||
-- 'PkgName' is also used as a key in 'DependencyMap' and 'ReverseDependencyMap'.
|
||||
-- In this case, 'PkgName' originally comes from attribute names in @haskellPackages@
|
||||
-- in Nixpkgs.
|
||||
newtype PkgName = PkgName Text
|
||||
deriving stock (Generic, Show)
|
||||
deriving newtype (Eq, FromJSON, FromJSONKey, Ord, ToJSON)
|
||||
|
||||
-- | A package set name. This is parsed from a 'JobName'.
|
||||
--
|
||||
-- Examples:
|
||||
--
|
||||
-- - The 'JobName' @"haskellPackages.lens.x86_64-linux"@ produces the 'PkgSet'
|
||||
-- @"haskellPackages"@.
|
||||
-- - The 'JobName' @"haskell.packages.ghc925.cabal-install.aarch64-darwin"@
|
||||
-- produces the 'PkgSet' @"haskell.packages.ghc925"@.
|
||||
-- - The 'JobName' @"pkgsMusl.haskell.compiler.ghc90.x86_64-linux"@ produces
|
||||
-- the 'PkgSet' @"pkgsMusl.haskell.compiler"@.
|
||||
-- - The 'JobName' @"arion.aarch64-linux"@ produces the 'PkgSet' @""@.
|
||||
--
|
||||
-- As you can see from the last example, 'PkgSet' can be empty (@""@) for
|
||||
-- top-level jobs.
|
||||
newtype PkgSet = PkgSet Text
|
||||
deriving stock (Generic, Show)
|
||||
deriving newtype (Eq, FromJSON, FromJSONKey, Ord, ToJSON)
|
||||
|
||||
data BuildResult = BuildResult {state :: BuildState, id :: Int} deriving (Show, Eq, Ord)
|
||||
newtype Platform = Platform {platform :: Text} deriving (Show, Eq, Ord)
|
||||
data SummaryEntry = SummaryEntry {
|
||||
summaryBuilds :: Table Text Platform BuildResult,
|
||||
summaryBuilds :: Table PkgSet Platform BuildResult,
|
||||
summaryMaintainers :: Set Text,
|
||||
summaryReverseDeps :: Int,
|
||||
summaryUnbrokenReverseDeps :: Int
|
||||
}
|
||||
type StatusSummary = Map Text SummaryEntry
|
||||
type StatusSummary = Map PkgName SummaryEntry
|
||||
|
||||
newtype Table row col a = Table (Map (row, col) a)
|
||||
|
||||
|
|
@ -413,32 +467,36 @@ combineStatusSummaries = foldl (Map.unionWith unionSummary) Map.empty
|
|||
unionSummary (SummaryEntry lb lm lr lu) (SummaryEntry rb rm rr ru) =
|
||||
SummaryEntry (unionTable lb rb) (lm <> rm) (max lr rr) (max lu ru)
|
||||
|
||||
buildToStatusSummary :: MaintainerMap -> ReverseDependencyMap -> Build -> StatusSummary
|
||||
buildToStatusSummary maintainerMap reverseDependencyMap build@Build{job, id, system} =
|
||||
Map.singleton name summaryEntry
|
||||
buildToPkgNameAndSet :: Build -> (PkgName, PkgSet)
|
||||
buildToPkgNameAndSet Build{job = JobName jobName, system} = (name, set)
|
||||
where
|
||||
jobName = unJobName job
|
||||
|
||||
packageName :: Text
|
||||
packageName = fromMaybe jobName (Text.stripSuffix ("." <> system) jobName)
|
||||
|
||||
splitted :: Maybe (NonEmpty Text)
|
||||
splitted = nonEmpty $ Text.splitOn "." packageName
|
||||
|
||||
name :: Text
|
||||
name = maybe packageName NonEmpty.last splitted
|
||||
name :: PkgName
|
||||
name = PkgName $ maybe packageName NonEmpty.last splitted
|
||||
|
||||
set :: Text
|
||||
set = maybe "" (Text.intercalate "." . NonEmpty.init) splitted
|
||||
set :: PkgSet
|
||||
set = PkgSet $ maybe "" (Text.intercalate "." . NonEmpty.init) splitted
|
||||
|
||||
buildToStatusSummary :: MaintainerMap -> ReverseDependencyMap -> Build -> StatusSummary
|
||||
buildToStatusSummary maintainerMap reverseDependencyMap build@Build{job, id, system} =
|
||||
Map.singleton pkgName summaryEntry
|
||||
where
|
||||
(pkgName, pkgSet) = buildToPkgNameAndSet build
|
||||
|
||||
maintainers :: Set Text
|
||||
maintainers = maybe mempty (Set.fromList . toList) (Map.lookup job maintainerMap)
|
||||
|
||||
(reverseDeps, unbrokenReverseDeps) = Map.findWithDefault (0,0) name reverseDependencyMap
|
||||
(reverseDeps, unbrokenReverseDeps) =
|
||||
Map.findWithDefault (0,0) pkgName reverseDependencyMap
|
||||
|
||||
buildTable :: Table Text Platform BuildResult
|
||||
buildTable :: Table PkgSet Platform BuildResult
|
||||
buildTable =
|
||||
singletonTable set (Platform system) (BuildResult (getBuildState build) id)
|
||||
singletonTable pkgSet (Platform system) (BuildResult (getBuildState build) id)
|
||||
|
||||
summaryEntry = SummaryEntry buildTable maintainers reverseDeps unbrokenReverseDeps
|
||||
|
||||
|
|
@ -462,19 +520,36 @@ printTable name showR showC showE (Table mapping) = joinTable <$> (name : map sh
|
|||
rows = toList $ Set.fromList (fst <$> Map.keys mapping)
|
||||
cols = toList $ Set.fromList (snd <$> Map.keys mapping)
|
||||
|
||||
printJob :: Int -> Text -> (Table Text Platform BuildResult, Text) -> [Text]
|
||||
printJob evalId name (Table mapping, maintainers) =
|
||||
printJob :: Int -> PkgName -> (Table PkgSet Platform BuildResult, Text) -> [Text]
|
||||
printJob evalId (PkgName name) (Table mapping, maintainers) =
|
||||
if length sets <= 1
|
||||
then map printSingleRow sets
|
||||
else ["- [ ] " <> makeJobSearchLink "" name <> " " <> maintainers] <> map printRow sets
|
||||
else ["- [ ] " <> makeJobSearchLink (PkgSet "") name <> " " <> maintainers] <> map printRow sets
|
||||
where
|
||||
printRow set = " - " <> printState set <> " " <> makeJobSearchLink set (if Text.null set then "toplevel" else set)
|
||||
printSingleRow set = "- [ ] " <> printState set <> " " <> makeJobSearchLink set (makePkgName set) <> " " <> maintainers
|
||||
makePkgName set = (if Text.null set then "" else set <> ".") <> name
|
||||
printState set = Text.intercalate " " $ map (\pf -> maybe "" (label pf) $ Map.lookup (set, pf) mapping) platforms
|
||||
makeJobSearchLink set linkLabel= makeSearchLink evalId linkLabel (makePkgName set)
|
||||
printRow :: PkgSet -> Text
|
||||
printRow (PkgSet set) =
|
||||
" - " <> printState (PkgSet set) <> " " <>
|
||||
makeJobSearchLink (PkgSet set) (if Text.null set then "toplevel" else set)
|
||||
|
||||
printSingleRow set =
|
||||
"- [ ] " <> printState set <> " " <>
|
||||
makeJobSearchLink set (makePkgName set) <> " " <> maintainers
|
||||
|
||||
makePkgName :: PkgSet -> Text
|
||||
makePkgName (PkgSet set) = (if Text.null set then "" else set <> ".") <> name
|
||||
|
||||
printState set =
|
||||
Text.intercalate " " $ map (\pf -> maybe "" (label pf) $ Map.lookup (set, pf) mapping) platforms
|
||||
|
||||
makeJobSearchLink :: PkgSet -> Text -> Text
|
||||
makeJobSearchLink set linkLabel = makeSearchLink evalId linkLabel (makePkgName set)
|
||||
|
||||
sets :: [PkgSet]
|
||||
sets = toList $ Set.fromList (fst <$> Map.keys mapping)
|
||||
|
||||
platforms :: [Platform]
|
||||
platforms = toList $ Set.fromList (snd <$> Map.keys mapping)
|
||||
|
||||
label pf (BuildResult s i) = "[[" <> platformIcon pf <> icon s <> "]](https://hydra.nixos.org/build/" <> showT i <> ")"
|
||||
|
||||
makeSearchLink :: Int -> Text -> Text -> Text
|
||||
|
|
@ -503,7 +578,7 @@ evalLine Eval{id, jobsetevalinputs = JobsetEvalInputs{nixpkgs = Nixpkgs{revision
|
|||
<> Text.pack (formatTime defaultTimeLocale "%Y-%m-%d %H:%M UTC" fetchTime)
|
||||
<> "*"
|
||||
|
||||
printBuildSummary :: Eval -> UTCTime -> StatusSummary -> [(Text, Int)] -> Text
|
||||
printBuildSummary :: Eval -> UTCTime -> StatusSummary -> [(PkgName, Int)] -> Text
|
||||
printBuildSummary eval@Eval{id} fetchTime summary topBrokenRdeps =
|
||||
Text.unlines $
|
||||
headline <> [""] <> tldr <> ((" * "<>) <$> (errors <> warnings)) <> [""]
|
||||
|
|
@ -519,36 +594,100 @@ printBuildSummary eval@Eval{id} fetchTime summary topBrokenRdeps =
|
|||
<> footer
|
||||
where
|
||||
footer = ["*Report generated with [maintainers/scripts/haskell/hydra-report.hs](https://github.com/NixOS/nixpkgs/blob/haskell-updates/maintainers/scripts/haskell/hydra-report.hs)*"]
|
||||
|
||||
headline =
|
||||
[ "### [haskell-updates build report from hydra](https://hydra.nixos.org/jobset/nixpkgs/haskell-updates)"
|
||||
, evalLine eval fetchTime ]
|
||||
, evalLine eval fetchTime
|
||||
]
|
||||
|
||||
totals :: [Text]
|
||||
totals =
|
||||
[ "#### Build summary"
|
||||
, ""
|
||||
]
|
||||
<> printTable "Platform" (\x -> makeSearchLink id (platform x <> " " <> platformIcon x) ("." <> platform x)) (\x -> showT x <> " " <> icon x) showT numSummary
|
||||
brokenLine (name, rdeps) = "[" <> name <> "](https://packdeps.haskellers.com/reverse/" <> name <> ") :arrow_heading_up: " <> Text.pack (show rdeps) <> " "
|
||||
] <>
|
||||
printTable
|
||||
"Platform"
|
||||
(\x -> makeSearchLink id (platform x <> " " <> platformIcon x) ("." <> platform x))
|
||||
(\x -> showT x <> " " <> icon x)
|
||||
showT
|
||||
numSummary
|
||||
|
||||
brokenLine :: (PkgName, Int) -> Text
|
||||
brokenLine (PkgName name, rdeps) =
|
||||
"[" <> name <> "](https://packdeps.haskellers.com/reverse/" <> name <>
|
||||
") :arrow_heading_up: " <> Text.pack (show rdeps) <> " "
|
||||
|
||||
numSummary = statusToNumSummary summary
|
||||
|
||||
jobsByState :: (BuildState -> Bool) -> Map Text SummaryEntry
|
||||
jobsByState :: (BuildState -> Bool) -> StatusSummary
|
||||
jobsByState predicate = Map.filter (predicate . worstState) summary
|
||||
|
||||
worstState :: SummaryEntry -> BuildState
|
||||
worstState = foldl' min Success . fmap state . summaryBuilds
|
||||
|
||||
fails :: Map Text SummaryEntry
|
||||
fails :: StatusSummary
|
||||
fails = jobsByState (== Failed)
|
||||
|
||||
failedDeps :: StatusSummary
|
||||
failedDeps = jobsByState (== DependencyFailed)
|
||||
|
||||
unknownErr :: StatusSummary
|
||||
unknownErr = jobsByState (\x -> x > DependencyFailed && x < TimedOut)
|
||||
withMaintainer = Map.mapMaybe (\e -> (summaryBuilds e,) <$> nonEmpty (Set.toList (summaryMaintainers e)))
|
||||
|
||||
withMaintainer :: StatusSummary -> Map PkgName (Table PkgSet Platform BuildResult, NonEmpty Text)
|
||||
withMaintainer =
|
||||
Map.mapMaybe
|
||||
(\e -> (summaryBuilds e,) <$> nonEmpty (Set.toList (summaryMaintainers e)))
|
||||
|
||||
withoutMaintainer :: StatusSummary -> StatusSummary
|
||||
withoutMaintainer = Map.mapMaybe (\e -> if Set.null (summaryMaintainers e) then Just e else Nothing)
|
||||
|
||||
optionalList :: Text -> [Text] -> [Text]
|
||||
optionalList heading list = if null list then mempty else [heading] <> list
|
||||
|
||||
optionalHideableList :: Text -> [Text] -> [Text]
|
||||
optionalHideableList heading list = if null list then mempty else [heading] <> details (showT (length list) <> " job(s)") list
|
||||
|
||||
maintainedList :: StatusSummary -> [Text]
|
||||
maintainedList = showMaintainedBuild <=< Map.toList . withMaintainer
|
||||
unmaintainedList = showBuild <=< sortOn (\(snd -> x) -> (negate (summaryUnbrokenReverseDeps x), negate (summaryReverseDeps x))) . Map.toList . withoutMaintainer
|
||||
showBuild (name, entry) = printJob id name (summaryBuilds entry, Text.pack (if summaryReverseDeps entry > 0 then " :arrow_heading_up: " <> show (summaryUnbrokenReverseDeps entry) <>" | "<> show (summaryReverseDeps entry) else ""))
|
||||
showMaintainedBuild (name, (table, maintainers)) = printJob id name (table, Text.intercalate " " (fmap ("@" <>) (toList maintainers)))
|
||||
|
||||
summaryEntryGetReverseDeps :: SummaryEntry -> (Int, Int)
|
||||
summaryEntryGetReverseDeps sumEntry =
|
||||
( negate $ summaryUnbrokenReverseDeps sumEntry
|
||||
, negate $ summaryReverseDeps sumEntry
|
||||
)
|
||||
|
||||
sortOnReverseDeps :: [(PkgName, SummaryEntry)] -> [(PkgName, SummaryEntry)]
|
||||
sortOnReverseDeps = sortOn (\(_, sumEntry) -> summaryEntryGetReverseDeps sumEntry)
|
||||
|
||||
unmaintainedList :: StatusSummary -> [Text]
|
||||
unmaintainedList = showBuild <=< sortOnReverseDeps . Map.toList . withoutMaintainer
|
||||
|
||||
showBuild :: (PkgName, SummaryEntry) -> [Text]
|
||||
showBuild (name, entry) =
|
||||
printJob
|
||||
id
|
||||
name
|
||||
( summaryBuilds entry
|
||||
, Text.pack
|
||||
( if summaryReverseDeps entry > 0
|
||||
then
|
||||
" :arrow_heading_up: " <> show (summaryUnbrokenReverseDeps entry) <>
|
||||
" | " <> show (summaryReverseDeps entry)
|
||||
else ""
|
||||
)
|
||||
)
|
||||
|
||||
showMaintainedBuild
|
||||
:: (PkgName, (Table PkgSet Platform BuildResult, NonEmpty Text)) -> [Text]
|
||||
showMaintainedBuild (name, (table, maintainers)) =
|
||||
printJob
|
||||
id
|
||||
name
|
||||
( table
|
||||
, Text.intercalate " " (fmap ("@" <>) (toList maintainers))
|
||||
)
|
||||
|
||||
tldr = case (errors, warnings) of
|
||||
([],[]) -> [":green_circle: **Ready to merge** (if there are no [evaluation errors](https://hydra.nixos.org/jobset/nixpkgs/haskell-updates))"]
|
||||
([],_) -> [":yellow_circle: **Potential issues** (and possibly [evaluation errors](https://hydra.nixos.org/jobset/nixpkgs/haskell-updates))"]
|
||||
|
|
@ -566,8 +705,8 @@ printBuildSummary eval@Eval{id} fetchTime summary topBrokenRdeps =
|
|||
if' (outstandingJobs (Platform "aarch64-darwin") > 100) "Too many outstanding jobs on aarch64-darwin."
|
||||
if' p e = if p then [e] else mempty
|
||||
outstandingJobs platform | Table m <- numSummary = Map.findWithDefault 0 (platform, Unfinished) m
|
||||
maintainedJob = Map.lookup "maintained" summary
|
||||
mergeableJob = Map.lookup "mergeable" summary
|
||||
maintainedJob = Map.lookup (PkgName "maintained") summary
|
||||
mergeableJob = Map.lookup (PkgName "mergeable") summary
|
||||
|
||||
printEvalInfo :: IO ()
|
||||
printEvalInfo = do
|
||||
|
|
|
|||
Loading…
Reference in a new issue