Skip to content

Commit 3a4c515

Browse files
hololeaphololeap
committed
Add option for experimental emerge invocation
Add `--mode=reinstall-atoms` flag which uses experimental emerge invocation (using `--reinstall-atoms`). The rationale is that by marking broken packages by using `--reinstall-atoms`, portage will pretend that they are not yet installed, thus forcing their reinstallation. `--update` is used and all installed Haskell packages are targeted so that the entire Haskell environment is examined. This has a side-effect of skipping packages that are masked or otherwise unavailable while still rebuilding needed dependencies that have been broken. A new `--target=world` option has been added exclusively for `--mode=reinstall-atoms`, which sets the portage target to `@world`. This will hopefully provide a way to update the entire system while fixing broken Haskell packages as they appear. Reorganize command line options quite a bit as well, adding `--mode` and `--target` options as well as convenience/legacy aliases. Bug: #18 Signed-off-by: hololeap <[email protected]>
1 parent de88261 commit 3a4c515

File tree

4 files changed

+337
-94
lines changed

4 files changed

+337
-94
lines changed

‎Distribution/Gentoo/CmdLine.hs

+76-21
Original file line numberDiff line numberDiff line change
@@ -44,12 +44,42 @@ instance CmdlineOpt WithCmd where
4444
argInfo RunOnly = ("run", Nothing)
4545

4646
optName _ = "action"
47-
4847
optDescription _ =
4948
"Specify whether to run the PM command or just print it"
50-
5149
optDefault _ = PrintAndRun
5250

51+
instance CmdlineOpt BuildTarget where
52+
argInfo OnlyInvalid = ("invalid", Just "broken Haskell packages")
53+
argInfo AllInstalled = ("all", Just "all installed Haskell packages")
54+
argInfo WorldTarget =
55+
( "world"
56+
, Just $ "@world set (only valid with portage package\n"
57+
++ "manager and reinstall-atoms mode)"
58+
)
59+
60+
optName _ = "target"
61+
optDescription _ =
62+
"Choose the type of packages for the PM to target"
63+
optDefault _ = OnlyInvalid
64+
65+
instance CmdlineOpt HackportMode where
66+
argInfo BasicMode = ("basic", Just "classic haskell-updater behavior")
67+
argInfo ListMode =
68+
( "list"
69+
, Just $ "just print a list of packages for rebuild,\n"
70+
++ "one package per line"
71+
)
72+
argInfo ReinstallAtomsMode =
73+
( "reinstall-atoms"
74+
, Just $ "experimental portage invocation using\n"
75+
++ "--reinstall-atoms (may be more useful in\n"
76+
++ "some situations)" )
77+
78+
optName _ = "mode"
79+
optDescription _ =
80+
"Mode of operation for haskell-updater"
81+
optDefault _ = BasicMode
82+
5383
argString :: CmdlineOpt a => a -> String
5484
argString = fst . argInfo
5585

@@ -63,10 +93,13 @@ argHelp _ = unlines $ [mainDesc] ++ (args >>= argLine)
6393
argLine a = case (L.lookup a argFields, argDescription a) of
6494
(Nothing, _) -> []
6595
(Just s, Nothing) -> [s]
66-
(Just s, Just d) -> [s ++ padding s ++ " : " ++ d]
67-
padding s =
68-
let mx = maximum $ length . snd <$> argFields
69-
in replicate (mx - length s) ' '
96+
(Just s, Just d) -> case lines d of
97+
(l:ls) -> [paddedFst s l] ++ (paddedRest <$> ls)
98+
_ -> []
99+
paddedFst s d =
100+
s ++ replicate (padMax - length s) ' ' ++ " : " ++ d
101+
paddedRest d = replicate (padMax + 3) ' ' ++ d
102+
padMax = maximum $ length . snd <$> argFields
70103
argFields = (\a -> (a, showArg a)) <$> args
71104
showArg a = " * " ++ argString a ++ showDef a
72105
showDef a
@@ -103,10 +136,10 @@ defRunModifier defPM raw = RM
103136
, withCmd = optDefault $ Proxy @WithCmd
104137
, rawPMArgs = raw
105138
, verbosity = Normal
106-
, listOnly = False
107139
, showHelp = False
108140
, showVer = False
109141
, target = OnlyInvalid
142+
, mode = BasicMode
110143
}
111144

112145
-- | Make sure there is at least one of 'UpdateAsNeeded' or 'UpdateDeep'
@@ -121,17 +154,7 @@ postProcessRM rm = rm { flags = flags' }
121154

122155
options :: [OptDescr (RunModifier -> Either String RunModifier)]
123156
options =
124-
[ Option ['c'] ["dep-check"]
125-
(naUpdate $ \r -> r { target = OnlyInvalid })
126-
"Check dependencies of Haskell packages."
127-
-- deprecated alias for 'dep-check'
128-
, Option ['u'] ["upgrade"]
129-
(naUpdate $ \r -> r { target = OnlyInvalid })
130-
"Rebuild Haskell packages after a GHC upgrade."
131-
, Option ['a'] ["all"]
132-
(naUpdate $ \r -> r { target = AllInstalled })
133-
"Rebuild all Haskell libraries built with current GHC."
134-
, Option ['P'] ["package-manager"]
157+
[ Option ['P'] ["package-manager"]
135158
(ReqArg mkPM "PM")
136159
$ "Use package manager PM, where PM can be one of:\n"
137160
++ pmList ++ defPM
@@ -145,15 +168,43 @@ options =
145168
, Option [] ["no-deep"]
146169
(naUpdate $ \r -> r { flags = UpdateAsNeeded : flags r } )
147170
"Don't pull deep dependencies (--deep with emerge)."
148-
, Option ['l'] ["list-only"]
149-
(naUpdate $ \r -> r { listOnly = True })
150-
"Output only list of packages for rebuild. One package per line."
151171
, Option ['V'] ["version"]
152172
(naUpdate $ \r -> r { showVer = True })
153173
"Version information."
154174
, Option [] ["action"]
155175
(ReqArg (fromCmdline (\a r -> r { withCmd = a })) "action")
156176
(argHelp (Proxy @WithCmd))
177+
, Option [] ["target"]
178+
(ReqArg (fromCmdline (\a r -> r { target = a })) "target")
179+
(argHelp (Proxy @BuildTarget))
180+
, Option ['c'] ["dep-check"]
181+
(naUpdate $ \r -> r { target = OnlyInvalid })
182+
$ "alias for --target=" ++ argString OnlyInvalid
183+
-- deprecated alias for 'dep-check'
184+
, Option ['u'] ["upgrade"]
185+
(naUpdate $ \r -> r { target = OnlyInvalid })
186+
$ "alias for --target=" ++ argString OnlyInvalid
187+
, Option ['a'] ["all"]
188+
(naUpdate $ \r -> r { target = AllInstalled })
189+
$ "alias for --target=" ++ argString AllInstalled
190+
, Option ['W'] ["world"]
191+
(naUpdate $ \r -> r
192+
{ pkgmgr = Portage
193+
, target = WorldTarget
194+
, mode = ReinstallAtomsMode
195+
}
196+
) $ "alias for --package-manager=portage"
197+
++ " \\\n --target=" ++ argString WorldTarget
198+
++ " \\\n --mode=" ++ argString ReinstallAtomsMode
199+
, Option [] ["mode"]
200+
(ReqArg (fromCmdline (\a r -> r { mode = a })) "mode")
201+
(argHelp (Proxy @HackportMode))
202+
, Option ['l'] ["list-only"]
203+
(naUpdate $ \r -> r { mode = ListMode })
204+
$ "alias for --mode=" ++ argString ListMode
205+
, Option ['R'] ["reinstall-atoms"]
206+
(naUpdate $ \r -> r { mode = ReinstallAtomsMode })
207+
$ "alias for --mode=" ++ argString ReinstallAtomsMode
157208
, Option ['q'] ["quiet"]
158209
(naUpdate $ \r -> r { verbosity = Quiet })
159210
"Print only fatal errors (to stderr)."
@@ -164,6 +215,7 @@ options =
164215
(naUpdate $ \r -> r { showHelp = True })
165216
"Print this help message."
166217
]
218+
167219
where
168220
naUpdate f = NoArg (pure . f)
169221

@@ -181,3 +233,6 @@ options =
181233
\The default package manager is: " ++ defaultPMName ++ ",\n\
182234
\which can be overriden with the \"PACKAGE_MANAGER\"\n\
183235
\environment variable."
236+
237+
238+

‎Distribution/Gentoo/PkgManager.hs

+26
Original file line numberDiff line numberDiff line change
@@ -15,6 +15,7 @@ module Distribution.Gentoo.PkgManager
1515
, defaultPMName
1616
, nameOfPM
1717
, buildCmd
18+
, buildAltCmd
1819
) where
1920

2021
import Distribution.Gentoo.Packages
@@ -106,6 +107,31 @@ buildCmd pm fs raw_pm_flags ps = (pmCommand pm, fs' ++ ps')
106107
fs' = defaultPMFlags pm ++ mapMaybe (flagRep pm) fs ++ raw_pm_flags
107108
ps' = map printPkg ps
108109

110+
-- | Alternative version of 'buildCmd' which uses experimental @emerge@
111+
-- invocation (using @--reinstall-atoms@). This is only to be used with the
112+
-- 'Portage' 'PkgManager'.
113+
--
114+
-- The rationale is that by marking broken packages by using
115+
-- @--reinstall-atoms@, portage will pretend that they are not yet
116+
-- installed, thus forcing their reinstallation. @--update@ is
117+
-- used and all installed Haskell packages are targeted so that the entire
118+
-- Haskell environment is examined. This has a side-effect of skipping
119+
-- packages that are masked or otherwise unavailable while still rebuilding
120+
-- needed dependencies that have been broken.
121+
buildAltCmd
122+
:: [PMFlag] -- ^ Basic flags
123+
-> [String] -- ^ User-supplied flags
124+
-> [Package] -- ^ List of packages to rebuild
125+
-- | List of /all/ installed haskell packages ('Nothing' denotes a @world@ target)
126+
-> Maybe [Package]
127+
-> (String, [String])
128+
buildAltCmd fs rawPmFlags ps allPs =
129+
(pmCommand Portage, fs' ++ reinst ++ rawPmFlags ++ allPs')
130+
where
131+
fs' = defaultPMFlags Portage ++ mapMaybe (flagRep Portage) fs ++ ["--update"]
132+
reinst = ["--reinstall-atoms", unwords (map printPkg ps)]
133+
allPs' = maybe ["@world"] (map printPkg) allPs
134+
109135
-- -----------------------------------------------------------------------------
110136

111137
flagRep :: PkgManager -> PMFlag -> Maybe String

‎Distribution/Gentoo/Types.hs

+87-6
Original file line numberDiff line numberDiff line change
@@ -4,23 +4,33 @@ module Distribution.Gentoo.Types
44
, WithCmd(..)
55
, WithUserCmd
66
, BuildTarget(..)
7+
, HackportMode(..)
8+
, PackageState(..)
9+
, DefaultModePkgs(..)
10+
, ListModePkgs(..)
11+
, RAModePkgs(..)
12+
, HasTargets(..)
13+
, InvalidPkgs(..)
14+
, AllPkgs(..)
15+
, PackageList(..)
716
) where
817

18+
import Distribution.Gentoo.Packages
919
import Distribution.Gentoo.PkgManager.Types
1020
import Output
1121

12-
-- Full haskell-updater state
22+
-- | Full haskell-updater state
1323
data RunModifier = RM { pkgmgr :: PkgManager
1424
, flags :: [PMFlag]
1525
, withCmd :: WithCmd
1626
, rawPMArgs :: [String]
1727
, verbosity :: Verbosity
18-
, listOnly :: Bool
1928
, showHelp :: Bool
2029
, showVer :: Bool
2130
, target :: BuildTarget
31+
, mode :: HackportMode
2232
}
23-
deriving (Eq, Ord, Show, Read)
33+
deriving (Eq, Ord, Show)
2434

2535
data WithCmd = PrintAndRun
2636
| PrintOnly
@@ -29,6 +39,77 @@ data WithCmd = PrintAndRun
2939

3040
type WithUserCmd = Either String WithCmd
3141

32-
data BuildTarget = OnlyInvalid
33-
| AllInstalled -- Rebuild every haskell package
34-
deriving (Eq, Ord, Show, Read)
42+
data BuildTarget
43+
= OnlyInvalid -- ^ Default
44+
| AllInstalled -- ^ Rebuild every haskell package
45+
| WorldTarget -- ^ Target @world portage set
46+
deriving (Eq, Ord, Show, Read, Enum, Bounded)
47+
48+
data HackportMode
49+
= BasicMode
50+
| ListMode
51+
| ReinstallAtomsMode
52+
deriving (Show, Eq, Ord, Enum, Bounded)
53+
54+
-- | The current package list(s) organized by mode and build target
55+
data PackageState
56+
= DefaultModeState (Maybe DefaultModePkgs)
57+
| ListModeState ListModePkgs
58+
| RAModeState (Maybe RAModePkgs)
59+
deriving (Show, Eq, Ord)
60+
61+
data DefaultModePkgs
62+
= DefaultInvalid InvalidPkgs
63+
| DefaultAll AllPkgs
64+
deriving (Show, Eq, Ord)
65+
66+
data ListModePkgs
67+
= ListInvalid InvalidPkgs
68+
| ListAll AllPkgs
69+
deriving (Show, Eq, Ord)
70+
71+
data RAModePkgs
72+
= RAModeInvalid AllPkgs InvalidPkgs
73+
| RAModeAll AllPkgs
74+
| RAModeWorld InvalidPkgs
75+
deriving (Show, Eq, Ord)
76+
77+
class HasTargets t where
78+
targets :: t -> [Package]
79+
80+
instance HasTargets PackageState where
81+
targets (DefaultModeState ps) = targets ps
82+
targets (ListModeState ps) = targets ps
83+
targets (RAModeState ps) = targets ps
84+
85+
instance HasTargets DefaultModePkgs where
86+
targets (DefaultInvalid ps) = getPkgs ps
87+
targets (DefaultAll ps) = getPkgs ps
88+
89+
instance HasTargets ListModePkgs where
90+
targets (ListInvalid ps) = getPkgs ps
91+
targets (ListAll ps) = getPkgs ps
92+
93+
instance HasTargets RAModePkgs where
94+
targets (RAModeInvalid _ ps) = getPkgs ps
95+
targets (RAModeAll ps) = getPkgs ps
96+
targets (RAModeWorld ps) = getPkgs ps
97+
98+
instance HasTargets t => HasTargets (Maybe t) where
99+
targets (Just ps) = targets ps
100+
targets Nothing = []
101+
102+
newtype InvalidPkgs = InvalidPkgs [Package]
103+
deriving (Show, Eq, Ord)
104+
105+
newtype AllPkgs = AllPkgs [Package]
106+
deriving (Show, Eq, Ord)
107+
108+
class PackageList t where
109+
getPkgs :: t -> [Package]
110+
111+
instance PackageList InvalidPkgs where
112+
getPkgs (InvalidPkgs ps) = ps
113+
114+
instance PackageList AllPkgs where
115+
getPkgs (AllPkgs ps) = ps

0 commit comments

Comments
 (0)