Skip to content

GitLab

Commit 4104086b authored by Ben Gamari's avatar Ben Gamari
Browse files

Introduce label fixup

parent 964a1b19
Hide whitespace changes
Inline Side-by-side
Main.hs
View file @ 4104086b
......@@ -57,6 +57,7 @@ data Mode = Import { skipMilestones :: Bool
, keepWikiGit :: Bool
, ticketNumbers :: S.Set TicketNumber
}
| FixLabels
| TestParser
| TestScraper [String]
| TestParserOnly
......@@ -67,6 +68,7 @@ mode = hsubparser $
<> command "test-parser" (info (helper <*> pure TestParser) (progDesc "test ticket parser and Markdown writer"))
<> command "test-parser-only" (info (helper <*> pure TestParserOnly) (progDesc "test ticket parser"))
<> command "test-scraper" (info (helper <*> testScraperMode) (progDesc "test wiki parser"))
<> command "fix-ticket-labels" (info (helper <*> pure FixLabels) (progDesc "import missing ticket labels"))
importMode :: Parser Mode
importMode =
......@@ -184,6 +186,12 @@ main = do
$ Logging.withContext logger "ticket fixup" $ printErrors logger
$ fixupLastUpdated logger
FixLabels -> do
conn <- connectPostgreSQL tracDsn
env <- makeGitLabEnv
tickets <- getTickets conn
runClientM (mapM_ fixLabels tickets) env >>= throwLeft
where
throwLeft :: (Exception e, Monad m, MonadThrow m) => Either e a -> m a
throwLeft = either throwM return
......
TicketImport.hs
View file @ 4104086b
......@@ -6,12 +6,15 @@
module TicketImport
( createTicket
, createTicketChanges
, fixLabels
) where
import Control.Applicative
import Control.Concurrent
import Control.Monad
import Data.Bifunctor
import Data.Char
import Data.Either
import Data.Maybe
import Data.String
import Control.Monad.IO.Class
......@@ -66,40 +69,94 @@ toAddRemove f (Update old new) =
-- | Maps Trac keywords to labels
keywordLabels :: Text -> Labels
keywordLabels =
fromMaybe mempty . flip M.lookup labelMapping
fromMaybe mempty . flip M.lookup labelMapping . T.toCaseFold
where
labelMapping :: M.Map Text Labels
labelMapping =
M.fromList
$ map (first T.toCaseFold)
$ [ passthru "newcomer"
, ("newcomers", "newcomer")
, ("beginner", "newcomer")
, ("easy", "newcomer")
, ("CI", "infrastructure")
, ("windows", "Windows")
, ("Msys2", "Windows")
, ("Win32", "Windows")
, ("PowerPC", "PowerPC")
, ("macOS", "macOS")
, ("osx", "macOS")
, ("darwin", "macOS")
, ("mac", "macOS")
, ("ios", "macOS")
, ("cross-compiling", "cross-compilation")
, ("cross-compile", "cross-compilation")
, ("crosscompile", "cross-compilation")
, ("cross", "cross-compilation")
, passthru "unregisterised"
, ("unregisterize", "unregisterised")
, passthru "ConstraintKinds"
, passthru "ImplicitParams"
, ("polykinds", "PolyKinds")
, passthru "TypeInType"
, ("LevityPolymorphism", "levity polymorphism")
, passthru "type families"
, ("TypeFamilies", "type families")
, passthru "RankNTypes"
, passthru "hadrian"
, ("PEi386", "Windows" <> "linking")
, ("sparc64", "SPARC")
, ("raspberry", "ARM")
, ("raspberrypi", "ARM")
, ("arm", "ARM")
, ("armv7", "ARM")
, ("concurrency", "concurrency")
, ("SMP", "concurrency")
, ("threads", "concurrency")
, ("threaded", "concurrency")
, ("GC", "RTS")
, ("AmbiguityCheck", "ambiguity check")
, ("ImpredicativeTypes", "ImpredicativeTypes")
, ("impredicativity", "ImpredicativeTypes")
, ("link", "linking")
, passthru "pattern synonyms"
, passthru "deriving"
, passthru "DerivingVia"
, passthru "RebindableSyntax"
, ("Deriving", "deriving")
, ("GeneralizedNewtypeDeriving", "deriving")
, ("GeneralisedNewtypeDeriving", "deriving")
, passthru "generics"
, ("DeriveGeneric", "generics")
, ("Generics", "generics")
, ("Generic1", "generics")
, passthru "pattern match warnings"
, passthru "inlining"
, ("PatternMatchWarnings", "pattern match warnings")
, passthru "quantified constraints"
, passthru "TypeApplications"
, passthru "levity polymorphism"
, passthru "code-gen"
, ("codegen", "code-gen")
, passthru "GADTs"
, ("GADT", "GADTs")
, ("rts", "RTS")
, "JoinPoints" .= "join points"
, passthru "Typeable"
, ("Typeable", "Typeable")
, ("ORF", "OverloadedRecordFields")
, ("ORF", "OverloadedRecordFields" <> "records")
, ("orf", "OverloadedRecordFields" <> "records")
, ("hs-boot", "hs-boot")
, passthru "spec constr"
, passthru "ApplicativeDo"
, passthru "demand analysis"
, ("FunDeps", "functional dependencies")
, ("FunctionalDependencies", "functional dependencies")
, passthru "MultiParamTypeClasses"
, "TypedHoles" .= "typed holes"
, "typed-holes" .= "typed holes"
, "holes" .= "typed holes"
, passthru "CSE"
, ("DemandAnalysis", "demand analysis")
, ("plugin", "plugins")
, ("plugins", "plugins")
, ("TypeCheckerPlugins", "plugins")
, ("deriving-perf", "deriving" <> "compiler perf")
, passthru "CUSKs"
......@@ -107,29 +164,80 @@ keywordLabels =
, ("performance", "runtime perf")
, ("ci-breakage", "CI breakage")
, ("DWARF", "debug information")
, ("STM", "STM")
, ("TChan", "STM")
, ("throwSTM", "STM")
, passthru "InstanceSigs"
, passthru "DefaultSignatures"
, passthru "SafeHaskell"
, passthru "custom type errors"
, ("CustomTypeErrors", "custom type errors")
, passthru "StaticPointers"
, passthru "UndecideableInstances"
, ("UndecidableInstances", "UndecideableInstances")
, passthru "IncoherentInstances"
, passthru "ScopedTypeVariables"
, passthru "ViewPatterns"
, passthru "VisibleDependentQuantification"
, passthru "utf"
, passthru "utf-8"
, passthru "utf8"
, passthru "Unicode"
, ("UnicodeSyntax", "Unicode")
, ("unicode", "Unicode")
, ("documentation", "documentation")
, ("manpage", "documentation")
, ("manpages", "documentation")
, ("split-objs", "split-objs")
, ("SplitObjs", "split-objs")
, ("TypeErrors", "error messages")
, ("TypeErrorMessages", "error messages")
, ("error messages", "error messages")
, ("ErrorMessages", "error messages")
, ("warnings", "error messages")
, ("warning", "error messages")
, ("profiling", "profiling")
, passthru "Arrows"
, ("arrows", "Arrows")
, passthru "SIMD"
, passthru "sse2"
, passthru "TemplateHaskell"
, ("template-haskell", "TemplateHaskell")
, ("template", "TemplateHaskell")
, ("TH", "TemplateHaskell")
, passthru "backpack"
, passthru "ImpredicativeTypes"
, ("Roles", "roles")
, ("existentialquantification", "ExistentialQuantification")
, ("XOverlappingInstances", "OverlappingInstances")
, ("OverlappingInstances", "OverlappingInstances")
, ("NamedWildCards", "holes")
, ("RecordWildCards", "RecordWildCards" <> "records")
, ("Records", "records")
, ("duplicaterecordfields", "records")
, ("FFI", "FFI")
, ("GHCi", "GHCi")
, ("roles", "roles")
, ("admin", "infrastructure")
, ("git", "infrastructure")
, ("UnboxedSums", "UnboxedSums")
, ("UnboxedSum", "UnboxedSums")
, ("UnboxedTuples", "UnboxedTuples")
, ("Safe", "Safe Haskell")
, passthru "DataKinds"
, passthru "exceptions"
, passthru "debugger"
, ("synonyms", "pattern synonyms") -- generally arises from typos
, ("PatternSynonyms", "pattern synonyms") -- generally arises from typos
, passthru "cpp"
, ("TypedTemplateHaskell", "typed TemplateHaskell" <> "TemplateHaskell")
, passthru "strings"
, passthru "clang"
, ("FloatOut", "float-out")
, passthru "LLVM"
, ("FloatOut", "simplifier" <> "float-out")
, passthru "SpecConstr"
, passthru "QuantifiedContexts"
, ("QuantifiedConstraints", "QuantifiedContexts")
, ("APIAnnotations", "API Annotations")
, passthru "InjectiveFamilies"
, passthru "performance"
, ("CPRAnalysis", "CPR analysis")
......@@ -137,14 +245,45 @@ keywordLabels =
, ("PartialTypeSignatures", "partial type sigs")
, passthru "SafeHaskell"
, ("RemoteGHCi", "remote GHCi")
, ("injective", "injective type families")
, ("specialisation", "specialisation")
, ("stream-fusion", "stream fusion")
, ("fusion", "stream fusion")
, ("gmp", "integer-gmp")
, passthru "integer-gmp"
, passthru "integer-simple"
, ("recompilation", "recompilation checking")
, ("RecompilationCheck", "recompilation checking")
, ("recompilation", "recompilation checking")
, ("LateLamLift", "late lambda lifting")
, ("Simplifier", "simplifier")
, ("Inlining", "simplifier" <> "inlining")
, passthru "DeferredTypeErrors"
, passthru "UndecidableSuperClasses"
, passthru "CAFs"
, passthru "rules"
, passthru "haddock"
, passthru "linking"
, ("rounding", "numerics")
, ("ieee754", "numerics")
, ("Number", "numerics")
, ("Numeric", "numerics")
, ("Numerics", "numerics")
, ("linker", "linking")
, ("base", "core libraries")
, ("AMP", "core libraries")
, ("ghc-prim", "core libraries")
, ("CodeGen", "code generation")
, ("hpc", "HPC")
, ("nofib", "nofib")
, ("numa", "NUMA" <> "RTS")
, ("interpreter", "GHCi")
, ("TypeableReflection", "Typeable")
, ("Typeable", "Typeable")
, ("DPH", "Data Parallel Haskell")
, ("segfault", "runtime crash")
, ("segv", "runtime crash")
, ("segmentation", "runtime crash")
]
where
passthru x = (x, mkLabel x)
......@@ -224,6 +363,11 @@ ticketTypeLabel Task = "task"
ticketTypeLabel FeatureRequest = "feature request"
ticketTypeLabel MergeReq = "backport request"
statusLabel :: Trac.Status -> Labels
statusLabel Merge = "backport"
statusLabel Upstream = "upstream"
statusLabel _ = mempty
fieldLabels :: Fields Update -> AddRemove Labels
fieldLabels fields =
add "Trac import"
......@@ -236,12 +380,9 @@ fieldLabels fields =
keywordLbls = toAddRemove id $ fmap (foldMap keywordLabels) (ticketKeywords fields)
typeLbls = toAddRemove ticketTypeLabel (ticketType fields)
failureLbls = toAddRemove typeOfFailureLabels (ticketTypeOfFailure fields)
statusLbls = toAddRemove toStatusLabel (ticketStatus fields)
statusLbls = toAddRemove statusLabel (ticketStatus fields)
componentLbls = toAddRemove componentLabels (ticketComponent fields)
toStatusLabel Merge = "backport"
toStatusLabel Upstream = "upstream"
toStatusLabel _ = mempty
createTicket :: Logger
-> MilestoneMap
......@@ -732,3 +873,55 @@ nthMay n = listToMaybe . drop n
dummyLookupAnchor :: String -> Maybe String
dummyLookupAnchor = Just
fixLabels :: Ticket -> ClientM ()
fixLabels ticket = do
liftIO $ mapM_ (\kw -> putStrLn $ "Dropping keyword " ++ show kw) droppedKeywords
unless (nullLabels keywordLbls) $ do
let iid = ticketNumberToIssueIid $ ticketNumber ticket
issue <- getIssue gitlabToken project iid
liftIO $ putStrLn $ "Adding labels " ++ show (labels `diffLabels` irLabels issue)
let edit = EditIssue { eiTitle = Nothing
, eiDescription = Nothing
, eiMilestoneId = Nothing
, eiLabels = Just $ labels <> irLabels issue
, eiStatus = Nothing
, eiUpdateTime = Nothing
, eiWeight = Nothing
, eiAssignees = Nothing
, eiKeywords = Nothing
}
liftIO $ print edit
--void $ editIssue gitlabToken Nothing project iid edit
where
keywordToLabels :: Text -> Either Text Labels
keywordToLabels keyword =
case keywordLabels keyword of
xs | nullLabels xs -> Left keyword
| otherwise -> Right xs
(droppedKeywords, keywordLbls) =
second fold $ partitionEithers $ map keywordToLabels
$ toList $ runIdentity $ ticketKeywords fields
hasKeyword kw = kw `S.member` runIdentity (ticketKeywords fields)
typeFamilies
| hasKeyword "type" && (hasKeyword "family" || hasKeyword "families") = "type families"
| otherwise = mempty
dataFamilies
| hasKeyword "data" && (hasKeyword "family" || hasKeyword "families") = "data families"
| otherwise = mempty
fields = ticketFields ticket
typeLbls = ticketTypeLabel $ runIdentity $ ticketType fields
failureLbls = typeOfFailureLabels $ runIdentity $ ticketTypeOfFailure fields
statusLbls = statusLabel $ runIdentity $ ticketStatus fields
componentLbls = componentLabels $ runIdentity $ ticketComponent fields
labels = "Trac import"
<> typeFamilies
<> keywordLbls
<> failureLbls
<> typeLbls
<> statusLbls
<> componentLbls
Markdown is supported
0% or .
You are about to add 0 people to the discussion. Proceed with caution.
Finish editing this message first!
Please register or to comment