Skip to content

Commit 6e250fe

Browse files
hololeaphololeap
committed
Allow mixing/matching of targets
Allow multiple targets to be used. For instance: all broken packages, @world set, and custom targets can all be chosen simultaneously. Only valid for --mode=reinstall-atoms. Other modes will simply use the last target given. Signed-off-by: hololeap <[email protected]>
1 parent eefa651 commit 6e250fe

File tree

6 files changed

+180
-76
lines changed

6 files changed

+180
-76
lines changed

‎Distribution/Gentoo/CmdLine.hs

+58-31
Original file line numberDiff line numberDiff line change
@@ -18,14 +18,19 @@ module Distribution.Gentoo.CmdLine
1818
) where
1919

2020
import Control.Monad ((>=>))
21+
import qualified Data.List.NonEmpty as NE
22+
import Data.Monoid (Ap(..))
23+
import Data.Maybe (fromMaybe)
2124
import Data.Proxy
25+
import Data.Semigroup (Last(..), sconcat)
2226
import System.Console.GetOpt
2327

2428
import Distribution.Gentoo.CmdLine.Types
2529
import Distribution.Gentoo.PkgManager
2630
import Distribution.Gentoo.PkgManager.Types
2731
import Distribution.Gentoo.Types
2832
import qualified Distribution.Gentoo.Types.HUMode as Mode
33+
import Distribution.Gentoo.Util (These(..), singletonNE)
2934
import Output
3035

3136
-- | Process arguments from the command line. Returns an error string if the
@@ -59,13 +64,15 @@ mkHUMode cmdLine raw
5964
-- Logic for parsing modes for non-portage package managers
6065
mkMode :: RunMode -> Either String Mode.RunMode
6166
mkMode = \case
62-
BasicMode -> Mode.BasicMode <$> mkTarget (cmdLineTarget cmdLine)
63-
ListMode -> Mode.ListMode <$> mkTarget (cmdLineTarget cmdLine)
67+
BasicMode -> Mode.BasicMode <$> go (cmdLineTargets cmdLine)
68+
ListMode -> Mode.ListMode <$> go (cmdLineTargets cmdLine)
6469
ReinstallAtomsMode -> Left
6570
"reinstall-atoms mode is only supported by the portage package manager"
71+
where
72+
go = maybe (Right Mode.OnlyInvalid) (onlyLast mkTarget)
6673

6774
-- Logic for parsing targets for non-portage package managers
68-
mkTarget :: Either CustomTargets BuildTarget -> Either String Mode.Target
75+
mkTarget :: Either CustomTarget BuildTarget -> Either String Mode.Target
6976
mkTarget = \case
7077
Right OnlyInvalid -> Right Mode.OnlyInvalid
7178
Right AllInstalled -> Right Mode.AllInstalled
@@ -83,36 +90,42 @@ mkHUMode cmdLine raw
8390
-> Either String Mode.PortageMode
8491
mkPortageMode = \case
8592
BasicMode -> Mode.PortageBasicMode
86-
<$> mkPortageBasicTarget (cmdLineTarget cmdLine)
93+
<$> withDefTarget
94+
(onlyLast mkPortageBasicTarget)
95+
maybeTargs
8796
ListMode -> Mode.PortageListMode
88-
<$> mkPortageTarget (cmdLineTarget cmdLine)
97+
<$> withDefTarget
98+
(onlyLast mkPortageTarget)
99+
maybeTargs
89100
ReinstallAtomsMode -> Mode.ReinstallAtomsMode
90-
<$> mkPortageRATarget (cmdLineTarget cmdLine)
101+
<$> withDefTarget mkPortageRATarget maybeTargs
102+
where
103+
maybeTargs = cmdLineTargets cmdLine
91104

92105
-- Logic for parsing targets for portage's basic mode
93106
mkPortageBasicTarget
94-
:: Either CustomTargets BuildTarget
107+
:: Either CustomTarget BuildTarget
95108
-> Either String (Either Mode.PortageBasicTarget Mode.Target)
96109
mkPortageBasicTarget = \case
97110
Right PreservedRebuild -> Right $ Left Mode.PreservedRebuild
98111
targ -> Right <$> mkPortageTarget targ
99112

100113
-- Logic for parsing targets for portage's reinstall-atoms mode
101114
mkPortageRATarget
102-
:: Either CustomTargets BuildTarget
103-
-> Either String (Either Mode.Target Mode.ReinstallAtomsTarget)
104-
mkPortageRATarget = \case
105-
Right WorldTarget -> Right $ Right $
115+
:: NE.NonEmpty (Either CustomTarget BuildTarget)
116+
-> Either String Mode.RATargets
117+
mkPortageRATarget = foldTargets $ \case
118+
Left ct -> Right $ That $ That $ singletonNE ct
119+
Right WorldTarget -> Right $ That $ This $
106120
if cmdLineWorldFull cmdLine
107121
then Mode.WorldFullTarget
108122
else Mode.WorldTarget
109-
Left cts -> Right $ Right $ Mode.CustomTargets cts
110-
targ -> Left <$> mkPortageTarget targ
123+
targ -> This <$> mkPortageTarget targ
111124

112125
-- Logic for parsing targets for portage's list mode; also common logic
113126
-- for parsing targets, between portage's basic and reinstall-atoms modes
114127
mkPortageTarget
115-
:: Either CustomTargets BuildTarget
128+
:: Either CustomTarget BuildTarget
116129
-> Either String Mode.Target
117130
mkPortageTarget = \case
118131
Right OnlyInvalid -> Right Mode.OnlyInvalid
@@ -135,6 +148,31 @@ mkHUMode cmdLine raw
135148
, verbosity = cmdLineVerbosity cmdLine
136149
}
137150

151+
-- Uses the default target if none were specified on the command line
152+
withDefTarget
153+
:: (NE.NonEmpty (Either CustomTarget BuildTarget) -> a)
154+
-> Maybe (NE.NonEmpty (Either CustomTarget BuildTarget))
155+
-> a
156+
withDefTarget f = f . fromMaybe (NE.singleton defTarget)
157+
where
158+
defTarget = Right OnlyInvalid
159+
160+
-- Uses 'Data.Semigroup.Last' to only grab the last target specified
161+
onlyLast
162+
:: Applicative f
163+
=> (a -> f b)
164+
-> NE.NonEmpty a
165+
-> f b
166+
onlyLast f = fmap (getLast . sconcat . fmap Last) . traverse f
167+
168+
-- Uses 'Data.Monoid.Ap' to combine RATargets inside an Applicative
169+
foldTargets
170+
:: (Applicative f, Semigroup b)
171+
=> (a -> f b)
172+
-> NE.NonEmpty a
173+
-> f b
174+
foldTargets f = getAp . sconcat . fmap (Ap . f)
175+
138176
options :: [OptDescr (CmdLineArgs -> Either String CmdLineArgs)]
139177
options =
140178
[ Option ['P'] ["package-manager"]
@@ -196,9 +234,8 @@ options =
196234
}
197235
)
198236
"target")
199-
$ "Use a custom target. May be given multiple times.\n"
200-
++ " Enables portage PM and reinstall-targets mode.\n"
201-
++ " Will override any non-custom targets."
237+
"Use a custom target. May be given multiple times.\n\
238+
\ Enables portage PM and reinstall-targets mode."
202239
, Option [] ["mode"]
203240
(ReqArg (fromCmdline (\a c -> c { cmdLineMode = a })) "mode")
204241
(argHelp (Proxy @RunMode))
@@ -237,18 +274,8 @@ options =
237274
\ which can be overriden with the \"PACKAGE_MANAGER\"\n\
238275
\ environment variable."
239276

240-
-- Custom targets always override BuildTargets
241-
-- New custom targets are appended to old custom targets
242-
-- New BuildTargets override old BuildTargets
243-
updateTarget :: Either String BuildTarget -> CmdLineArgs -> CmdLineArgs
277+
updateTarget :: Either CustomTarget BuildTarget -> CmdLineArgs -> CmdLineArgs
244278
updateTarget new old =
245-
let newT = case (new, cmdLineTarget old) of
246-
-- Override old BuildTargets with new BuildTargets
247-
(Right t, Right _) -> Right t
248-
-- Append new custom target
249-
(Left s, Left ss) -> Left $ ss ++ [s]
250-
-- Drop old BuildTargets for new custom target
251-
(Left s, Right _) -> Left [s]
252-
-- Drop new BuildTargets in favor of old custom targets
253-
(Right _, Left ss) -> Left ss
254-
in old { cmdLineTarget = newT }
279+
let ne = NE.singleton new
280+
newT = maybe ne (<> ne) (cmdLineTargets old)
281+
in old { cmdLineTargets = Just newT }

‎Distribution/Gentoo/CmdLine/Types.hs

+10-3
Original file line numberDiff line numberDiff line change
@@ -15,6 +15,7 @@ module Distribution.Gentoo.CmdLine.Types
1515
, defCmdLineArgs
1616
-- * sub types
1717
, BuildTarget(..)
18+
, CustomTarget
1819
, RunMode(..)
1920
, CmdlineOpt(..)
2021
-- * getter functions
@@ -27,6 +28,7 @@ module Distribution.Gentoo.CmdLine.Types
2728

2829
import Data.Char (toLower)
2930
import qualified Data.List as L
31+
import qualified Data.List.NonEmpty as NE
3032
import Data.Proxy
3133

3234
import Distribution.Gentoo.PkgManager.Types
@@ -40,10 +42,12 @@ data CmdLineArgs = CmdLineArgs
4042
, cmdLineNoDeep :: Bool
4143
, cmdLineVersion :: Bool
4244
, cmdLineAction :: WithCmd
43-
, cmdLineTarget :: Either CustomTargets BuildTarget
45+
, cmdLineTargets :: Maybe (NE.NonEmpty (Either CustomTarget BuildTarget))
4446
, cmdLineMode :: RunMode
4547
, cmdLineVerbosity :: Verbosity
4648
, cmdLineHelp :: Bool
49+
-- This would be better off as another BuildTarget option, but then we
50+
-- would lose the cool CmdlineOpt automagic
4751
, cmdLineWorldFull :: Bool
4852
} deriving (Show, Eq, Ord)
4953

@@ -54,7 +58,7 @@ defCmdLineArgs defPM = CmdLineArgs
5458
False
5559
False
5660
PrintAndRun
57-
(Right OnlyInvalid)
61+
Nothing
5862
BasicMode
5963
Normal
6064
False
@@ -67,6 +71,8 @@ data BuildTarget
6771
| PreservedRebuild -- ^ Append @preserved-rebuild set
6872
deriving (Eq, Ord, Show, Read, Enum, Bounded)
6973

74+
type CustomTarget = String
75+
7076
data RunMode
7177
= BasicMode
7278
| ListMode
@@ -117,7 +123,8 @@ instance CmdlineOpt BuildTarget where
117123

118124
optName _ = "target"
119125
optDescription _ =
120-
"Choose the type of packages for the PM to target"
126+
"Choose the type of packages for the PM to target.\n\
127+
\May be given multiple times in reinstall-atoms mode."
121128
optDefault _ = OnlyInvalid
122129

123130
instance CmdlineOpt RunMode where

‎Distribution/Gentoo/Types.hs

+3-5
Original file line numberDiff line numberDiff line change
@@ -4,14 +4,14 @@
44
General types needed for haskell-updater functionality
55
-}
66

7+
{-# LANGUAGE GeneralizedNewtypeDeriving #-}
78
{-# LANGUAGE TypeApplications #-}
89

910
module Distribution.Gentoo.Types
1011
( RunModifier(..)
1112
, RawPMArgs
1213
, WithCmd(..)
1314
, WithUserCmd
14-
, CustomTargets
1515
, PendingPackages(..)
1616
, Target(..)
1717
, RunHistory
@@ -48,8 +48,6 @@ data WithCmd = PrintAndRun
4848

4949
type WithUserCmd = Either String WithCmd
5050

51-
type CustomTargets = [String]
52-
5351
-- | The set of packages that are currently broken and need to be rebuilt,
5452
-- as reported by @ghc-pkg check@. These may or may not equate to the
5553
-- 'Target', depending on which mode @haskell-updater@ is running in.
@@ -101,10 +99,10 @@ newtype ExtraRawArgs = ExtraRawArgs [String]
10199
deriving (Show, Eq, Ord)
102100

103101
newtype InvalidPkgs = InvalidPkgs (Set.Set Package)
104-
deriving (Show, Eq, Ord)
102+
deriving (Show, Eq, Ord, Semigroup, Monoid)
105103

106104
newtype AllPkgs = AllPkgs (Set.Set Package)
107-
deriving (Show, Eq, Ord)
105+
deriving (Show, Eq, Ord, Semigroup, Monoid)
108106

109107
class PackageSet t where
110108
getPkgs :: t -> Set.Set Package

‎Distribution/Gentoo/Types/HUMode.hs

+48-6
Original file line numberDiff line numberDiff line change
@@ -9,6 +9,8 @@
99
-}
1010

1111
{-# LANGUAGE LambdaCase #-}
12+
{-# LANGUAGE FlexibleInstances #-}
13+
{-# LANGUAGE TypeSynonymInstances #-}
1214

1315
module Distribution.Gentoo.Types.HUMode
1416
( HUMode(..)
@@ -20,11 +22,16 @@ module Distribution.Gentoo.Types.HUMode
2022
, PortageMode(..)
2123
, PortageBasicTarget(..)
2224
, ReinstallAtomsTarget(..)
25+
, RATargets
2326
, getLoopType
2427
, getExtraRawArgs
2528
) where
2629

30+
import Data.Bifoldable (bifoldMap)
31+
import Data.Monoid (Last(..))
32+
2733
import Distribution.Gentoo.Types hiding (Target)
34+
import Distribution.Gentoo.Util (These(..), NESet(..))
2835

2936
data HUMode
3037
= HelpMode
@@ -49,10 +56,42 @@ data Target
4956
| AllInstalled
5057
deriving (Eq, Ord, Show)
5158

59+
type CustomTarget = String
60+
61+
-- | Encodes valid target combinations for 'ReinstallAtomsMode'
62+
type RATargets = These Target (These ReinstallAtomsTarget (NESet CustomTarget))
63+
64+
-- | Convenience function to turn RATargets into a triple of monoids, which helps
65+
-- in the Semigroup definition
66+
toMonoidTriple
67+
:: RATargets
68+
-> (Last Target, Last ReinstallAtomsTarget, Maybe (NESet CustomTarget))
69+
toMonoidTriple = bifoldMap
70+
(\t -> (pure t, mempty, mempty))
71+
(bifoldMap
72+
(\r -> (mempty, pure r, mempty))
73+
(\s -> (mempty, mempty, pure s))
74+
)
75+
76+
-- | No Monoid instance since there is intentionally no empty element
77+
instance Semigroup RATargets where
78+
sel1 <> sel2 = case conv (toMonoidTriple sel1 <> toMonoidTriple sel2) of
79+
(Just t, Just r, Just s) -> These t (These r s)
80+
(Just t, Just r, Nothing) -> These t (This r)
81+
(Just t, Nothing, Just s) -> These t (That s)
82+
(Just t, Nothing, Nothing) -> This t
83+
(Nothing, Just r, Just s) -> That (These r s)
84+
(Nothing, Just r, Nothing) -> That (This r)
85+
(Nothing, Nothing, Just s) -> That (That s)
86+
-- If there was an option for no targets, it would go here
87+
(Nothing, Nothing, Nothing) -> undefined
88+
where
89+
conv (Last mt, Last mr, ms) = (mt,mr,ms)
90+
5291
data PortageMode
5392
= PortageBasicMode (Either PortageBasicTarget Target)
5493
| PortageListMode Target
55-
| ReinstallAtomsMode (Either Target ReinstallAtomsTarget)
94+
| ReinstallAtomsMode RATargets
5695
deriving (Eq, Ord, Show)
5796

5897
data PortageBasicTarget = PreservedRebuild
@@ -61,7 +100,6 @@ data PortageBasicTarget = PreservedRebuild
61100
data ReinstallAtomsTarget
62101
= WorldTarget
63102
| WorldFullTarget
64-
| CustomTargets CustomTargets
65103
deriving (Eq, Ord, Show)
66104

67105
runMode :: PkgManager -> Either RunMode PortageMode
@@ -81,8 +119,8 @@ getTarget (ListMode t) = t
81119
-- sense.
82120
getLoopType :: PkgManager -> LoopType
83121
getLoopType = \case
84-
-- @--mode=reinstall-atoms@ should not loop if @--target=all@ is set
85-
Portage (ReinstallAtomsMode (Left AllInstalled)) -> NoLoop
122+
-- @--mode=reinstall-atoms@ should not loop if /only/ @--target=all@ is set
123+
Portage (ReinstallAtomsMode (This AllInstalled)) -> NoLoop
86124

87125
-- otherwise, it should always use UntilNoChange
88126
Portage (ReinstallAtomsMode _) -> UntilNoChange
@@ -114,6 +152,10 @@ getLoopType = \case
114152
-- manager.
115153
getExtraRawArgs :: PkgManager -> ExtraRawArgs
116154
getExtraRawArgs = ExtraRawArgs . \case
117-
Portage (ReinstallAtomsMode (Right WorldFullTarget)) ->
118-
["--newuse", "--with-bdeps=y"]
155+
Portage (ReinstallAtomsMode t) ->
156+
bifoldMap (const []) (bifoldMap fromRAT (const [])) t
119157
_ -> []
158+
where
159+
fromRAT = \case
160+
WorldFullTarget -> ["--newuse", "--with-bdeps=y"]
161+
WorldTarget -> []

0 commit comments

Comments
 (0)