Skip to content

Commit

Permalink
Add option for experimental emerge invocation
Browse files Browse the repository at this point in the history 
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]>
  • Loading branch information
@hololeap
hololeap committed May 25, 2024
1 parent de88261 commit 3a4c515
Show file tree
Hide file tree
Showing 4 changed files with 337 additions and 94 deletions.
97 changes: 76 additions & 21 deletions Distribution/Gentoo/CmdLine.hs
View file
Original file line number Diff line number Diff line change
Expand Up @@ -44,12 +44,42 @@ instance CmdlineOpt WithCmd where
argInfo RunOnly = ("run", Nothing)

optName _ = "action"

optDescription _ =
"Specify whether to run the PM command or just print it"

optDefault _ = PrintAndRun

instance CmdlineOpt BuildTarget where
argInfo OnlyInvalid = ("invalid", Just "broken Haskell packages")
argInfo AllInstalled = ("all", Just "all installed Haskell packages")
argInfo WorldTarget =
( "world"
, Just $ "@world set (only valid with portage package\n"
++ "manager and reinstall-atoms mode)"
)

optName _ = "target"
optDescription _ =
"Choose the type of packages for the PM to target"
optDefault _ = OnlyInvalid

instance CmdlineOpt HackportMode where
argInfo BasicMode = ("basic", Just "classic haskell-updater behavior")
argInfo ListMode =
( "list"
, Just $ "just print a list of packages for rebuild,\n"
++ "one package per line"
)
argInfo ReinstallAtomsMode =
( "reinstall-atoms"
, Just $ "experimental portage invocation using\n"
++ "--reinstall-atoms (may be more useful in\n"
++ "some situations)" )

optName _ = "mode"
optDescription _ =
"Mode of operation for haskell-updater"
optDefault _ = BasicMode

argString :: CmdlineOpt a => a -> String
argString = fst . argInfo

Expand All @@ -63,10 +93,13 @@ argHelp _ = unlines $ [mainDesc] ++ (args >>= argLine)
argLine a = case (L.lookup a argFields, argDescription a) of
(Nothing, _) -> []
(Just s, Nothing) -> [s]
(Just s, Just d) -> [s ++ padding s ++ " : " ++ d]
padding s =
let mx = maximum $ length . snd <$> argFields
in replicate (mx - length s) ' '
(Just s, Just d) -> case lines d of
(l:ls) -> [paddedFst s l] ++ (paddedRest <$> ls)
_ -> []
paddedFst s d =
s ++ replicate (padMax - length s) ' ' ++ " : " ++ d
paddedRest d = replicate (padMax + 3) ' ' ++ d
padMax = maximum $ length . snd <$> argFields
argFields = (\a -> (a, showArg a)) <$> args
showArg a = " * " ++ argString a ++ showDef a
showDef a
Expand Down Expand Up @@ -103,10 +136,10 @@ defRunModifier defPM raw = RM
, withCmd = optDefault $ Proxy @WithCmd
, rawPMArgs = raw
, verbosity = Normal
, listOnly = False
, showHelp = False
, showVer = False
, target = OnlyInvalid
, mode = BasicMode
}

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

options :: [OptDescr (RunModifier -> Either String RunModifier)]
options =
[ Option ['c'] ["dep-check"]
(naUpdate $ \r -> r { target = OnlyInvalid })
"Check dependencies of Haskell packages."
-- deprecated alias for 'dep-check'
, Option ['u'] ["upgrade"]
(naUpdate $ \r -> r { target = OnlyInvalid })
"Rebuild Haskell packages after a GHC upgrade."
, Option ['a'] ["all"]
(naUpdate $ \r -> r { target = AllInstalled })
"Rebuild all Haskell libraries built with current GHC."
, Option ['P'] ["package-manager"]
[ Option ['P'] ["package-manager"]
(ReqArg mkPM "PM")
$ "Use package manager PM, where PM can be one of:\n"
++ pmList ++ defPM
Expand All @@ -145,15 +168,43 @@ options =
, Option [] ["no-deep"]
(naUpdate $ \r -> r { flags = UpdateAsNeeded : flags r } )
"Don't pull deep dependencies (--deep with emerge)."
, Option ['l'] ["list-only"]
(naUpdate $ \r -> r { listOnly = True })
"Output only list of packages for rebuild. One package per line."
, Option ['V'] ["version"]
(naUpdate $ \r -> r { showVer = True })
"Version information."
, Option [] ["action"]
(ReqArg (fromCmdline (\a r -> r { withCmd = a })) "action")
(argHelp (Proxy @WithCmd))
, Option [] ["target"]
(ReqArg (fromCmdline (\a r -> r { target = a })) "target")
(argHelp (Proxy @BuildTarget))
, Option ['c'] ["dep-check"]
(naUpdate $ \r -> r { target = OnlyInvalid })
$ "alias for --target=" ++ argString OnlyInvalid
-- deprecated alias for 'dep-check'
, Option ['u'] ["upgrade"]
(naUpdate $ \r -> r { target = OnlyInvalid })
$ "alias for --target=" ++ argString OnlyInvalid
, Option ['a'] ["all"]
(naUpdate $ \r -> r { target = AllInstalled })
$ "alias for --target=" ++ argString AllInstalled
, Option ['W'] ["world"]
(naUpdate $ \r -> r
{ pkgmgr = Portage
, target = WorldTarget
, mode = ReinstallAtomsMode
}
) $ "alias for --package-manager=portage"
++ " \\\n --target=" ++ argString WorldTarget
++ " \\\n --mode=" ++ argString ReinstallAtomsMode
, Option [] ["mode"]
(ReqArg (fromCmdline (\a r -> r { mode = a })) "mode")
(argHelp (Proxy @HackportMode))
, Option ['l'] ["list-only"]
(naUpdate $ \r -> r { mode = ListMode })
$ "alias for --mode=" ++ argString ListMode
, Option ['R'] ["reinstall-atoms"]
(naUpdate $ \r -> r { mode = ReinstallAtomsMode })
$ "alias for --mode=" ++ argString ReinstallAtomsMode
, Option ['q'] ["quiet"]
(naUpdate $ \r -> r { verbosity = Quiet })
"Print only fatal errors (to stderr)."
Expand All @@ -164,6 +215,7 @@ options =
(naUpdate $ \r -> r { showHelp = True })
"Print this help message."
]

where
naUpdate f = NoArg (pure . f)

Expand All @@ -181,3 +233,6 @@ options =
\The default package manager is: " ++ defaultPMName ++ ",\n\
\which can be overriden with the \"PACKAGE_MANAGER\"\n\
\environment variable."



26 changes: 26 additions & 0 deletions Distribution/Gentoo/PkgManager.hs
View file
Original file line number Diff line number Diff line change
Expand Up @@ -15,6 +15,7 @@ module Distribution.Gentoo.PkgManager
, defaultPMName
, nameOfPM
, buildCmd
, buildAltCmd
) where

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

-- | Alternative version of 'buildCmd' which uses experimental @emerge@
-- invocation (using @--reinstall-atoms@). This is only to be used with the
-- 'Portage' 'PkgManager'.
--
-- 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.
buildAltCmd
:: [PMFlag] -- ^ Basic flags
-> [String] -- ^ User-supplied flags
-> [Package] -- ^ List of packages to rebuild
-- | List of /all/ installed haskell packages ('Nothing' denotes a @world@ target)
-> Maybe [Package]
-> (String, [String])
buildAltCmd fs rawPmFlags ps allPs =
(pmCommand Portage, fs' ++ reinst ++ rawPmFlags ++ allPs')
where
fs' = defaultPMFlags Portage ++ mapMaybe (flagRep Portage) fs ++ ["--update"]
reinst = ["--reinstall-atoms", unwords (map printPkg ps)]
allPs' = maybe ["@world"] (map printPkg) allPs

-- -----------------------------------------------------------------------------

flagRep :: PkgManager -> PMFlag -> Maybe String
Expand Down
93 changes: 87 additions & 6 deletions Distribution/Gentoo/Types.hs
View file
Original file line number Diff line number Diff line change
Expand Up @@ -4,23 +4,33 @@ module Distribution.Gentoo.Types
, WithCmd(..)
, WithUserCmd
, BuildTarget(..)
, HackportMode(..)
, PackageState(..)
, DefaultModePkgs(..)
, ListModePkgs(..)
, RAModePkgs(..)
, HasTargets(..)
, InvalidPkgs(..)
, AllPkgs(..)
, PackageList(..)
) where

import Distribution.Gentoo.Packages
import Distribution.Gentoo.PkgManager.Types
import Output

-- Full haskell-updater state
-- | Full haskell-updater state
data RunModifier = RM { pkgmgr :: PkgManager
, flags :: [PMFlag]
, withCmd :: WithCmd
, rawPMArgs :: [String]
, verbosity :: Verbosity
, listOnly :: Bool
, showHelp :: Bool
, showVer :: Bool
, target :: BuildTarget
, mode :: HackportMode
}
deriving (Eq, Ord, Show, Read)
deriving (Eq, Ord, Show)

data WithCmd = PrintAndRun
| PrintOnly
Expand All @@ -29,6 +39,77 @@ data WithCmd = PrintAndRun

type WithUserCmd = Either String WithCmd

data BuildTarget = OnlyInvalid
| AllInstalled -- Rebuild every haskell package
deriving (Eq, Ord, Show, Read)
data BuildTarget
= OnlyInvalid -- ^ Default
| AllInstalled -- ^ Rebuild every haskell package
| WorldTarget -- ^ Target @world portage set
deriving (Eq, Ord, Show, Read, Enum, Bounded)

data HackportMode
= BasicMode
| ListMode
| ReinstallAtomsMode
deriving (Show, Eq, Ord, Enum, Bounded)

-- | The current package list(s) organized by mode and build target
data PackageState
= DefaultModeState (Maybe DefaultModePkgs)
| ListModeState ListModePkgs
| RAModeState (Maybe RAModePkgs)
deriving (Show, Eq, Ord)

data DefaultModePkgs
= DefaultInvalid InvalidPkgs
| DefaultAll AllPkgs
deriving (Show, Eq, Ord)

data ListModePkgs
= ListInvalid InvalidPkgs
| ListAll AllPkgs
deriving (Show, Eq, Ord)

data RAModePkgs
= RAModeInvalid AllPkgs InvalidPkgs
| RAModeAll AllPkgs
| RAModeWorld InvalidPkgs
deriving (Show, Eq, Ord)

class HasTargets t where
targets :: t -> [Package]

instance HasTargets PackageState where
targets (DefaultModeState ps) = targets ps
targets (ListModeState ps) = targets ps
targets (RAModeState ps) = targets ps

instance HasTargets DefaultModePkgs where
targets (DefaultInvalid ps) = getPkgs ps
targets (DefaultAll ps) = getPkgs ps

instance HasTargets ListModePkgs where
targets (ListInvalid ps) = getPkgs ps
targets (ListAll ps) = getPkgs ps

instance HasTargets RAModePkgs where
targets (RAModeInvalid _ ps) = getPkgs ps
targets (RAModeAll ps) = getPkgs ps
targets (RAModeWorld ps) = getPkgs ps

instance HasTargets t => HasTargets (Maybe t) where
targets (Just ps) = targets ps
targets Nothing = []

newtype InvalidPkgs = InvalidPkgs [Package]
deriving (Show, Eq, Ord)

newtype AllPkgs = AllPkgs [Package]
deriving (Show, Eq, Ord)

class PackageList t where
getPkgs :: t -> [Package]

instance PackageList InvalidPkgs where
getPkgs (InvalidPkgs ps) = ps

instance PackageList AllPkgs where
getPkgs (AllPkgs ps) = ps
Loading

0 comments on commit 3a4c515

Please sign in to comment.