Skip to content

HTTPS clone URL

Subversion checkout URL

You can clone with
or
.
Download ZIP
Newer
Older
100644 274 lines (231 sloc) 10.171 kB
b4b9cbd @ivan-m Documentation and re-organisation
ivan-m authored
1 {- |
2 Module : Main
3 Description : The haskell-updater executable
d1b3fd5 @jkarlson Add support for custom package manager command flag.
jkarlson authored
4 Copyright : (c) Ivan Lazar Miljenovic, Stephan Friedrichs, Emil Karlson 2010
b4b9cbd @ivan-m Documentation and re-organisation
ivan-m authored
5 License : GPL-2 or later
6
7 The executable module of haskell-updater, which finds Haskell
8 packages to rebuild after a dep upgrade or a GHC upgrade.
9 -}
edcfb5f @ivan-m Start work on a new Main
ivan-m authored
10 module Main where
11
12 import Distribution.Gentoo.GHC
13 import Distribution.Gentoo.Packages
14 import Distribution.Gentoo.PkgManager
6634bf4 @ivan-m An attempt at being lazier for allGetPackages
ivan-m authored
15 import Distribution.Gentoo.Util
edcfb5f @ivan-m Start work on a new Main
ivan-m authored
16
5f53974 @ivan-m Re-write and update Main
ivan-m authored
17 import Data.Either(partitionEithers)
6634bf4 @ivan-m An attempt at being lazier for allGetPackages
ivan-m authored
18 import Data.List(foldl1', nub)
1b22875 Implement --version
Stephan Friedrichs authored
19 import Data.Version(showVersion)
5f53974 @ivan-m Re-write and update Main
ivan-m authored
20 import qualified Data.Set as Set
21 import Data.Set(Set)
1b22875 Implement --version
Stephan Friedrichs authored
22 import qualified Paths_haskell_updater as Paths(version)
a5db413 @ivan-m Define command-line flags
ivan-m authored
23 import System.Console.GetOpt
1682295 @ivan-m Define information on program usage
ivan-m authored
24 import System.Environment(getArgs, getProgName)
f69c425 @ivan-m Create die, and use success and die for help and err
ivan-m authored
25 import System.Exit(ExitCode(..), exitWith)
26 import System.IO(hPutStrLn, stderr)
942eef3 @trofi commandline: inhibit shell expansion of passed arguments
trofi authored
27 import Control.Monad(liftM, unless)
28 import System.Process(rawSystem)
ba5f16d @ivan-m Use explicit ExitCode stuff along with exitWith to ensure the program…
ivan-m authored
29
1a1eb70 @ivan-m Clean-up of Action usage
ivan-m authored
30 -- -----------------------------------------------------------------------------
b4b9cbd @ivan-m Documentation and re-organisation
ivan-m authored
31 -- The overall program.
1a1eb70 @ivan-m Clean-up of Action usage
ivan-m authored
32
6465537 @ivan-m Add main to Main
ivan-m authored
33 main :: IO ()
5f53974 @ivan-m Re-write and update Main
ivan-m authored
34 main = uncurry runAction =<< parseArgs
6465537 @ivan-m Add main to Main
ivan-m authored
35
b4b9cbd @ivan-m Documentation and re-organisation
ivan-m authored
36 -- -----------------------------------------------------------------------------
5f53974 @ivan-m Re-write and update Main
ivan-m authored
37 -- The possible actions that haskell-updater can perform.
38
39 data Action = Help
40 | Version
41 | Build { targets :: Set BuildTarget }
42 -- If anything is added here after Build, MAKE SURE YOU
43 -- UPDATE combineActions or it won't always work!
44 deriving (Eq, Ord, Show, Read)
45
46 defaultAction :: Action
47 defaultAction = Build $ Set.fromList [GhcUpgrade, DepCheck]
48
49 -- Combine all the actions together. If the list is empty, use the
50 -- defaultAction.
51 combineAllActions :: [Action] -> Action
52 combineAllActions = emptyElse defaultAction (foldl1' combineActions)
53
54 -- Combine two actions together. If they're both Build blah, merge
55 -- them; otherwise, pick the lower of the two (i.e. more important).
56 -- Note that it's safe (at the moment at least) to assume that when
57 -- the lower of one is a Build that they're both build.
58 combineActions :: Action -> Action -> Action
59 combineActions a1 a2 = case (a1 `min` a2) of
60 Build{} -> Build $ targets a1 `Set.union` targets a2
61 a -> a
62
63 runAction :: RunModifier -> Action -> IO a
64 runAction _ Help = help
65 runAction _ Version = version
fcd0508 @ivan-m Specify with the other information which package manager is being used.
ivan-m authored
66 runAction rm (Build ts) = do systemInfo rm
5f53974 @ivan-m Re-write and update Main
ivan-m authored
67 ps <- allGetPackages ts
68 buildPkgs rm ps
becbf1c @ivan-m Re-write PkgManager
ivan-m authored
69
b4b9cbd @ivan-m Documentation and re-organisation
ivan-m authored
70 -- -----------------------------------------------------------------------------
5f53974 @ivan-m Re-write and update Main
ivan-m authored
71 -- The possible things to build.
edcfb5f @ivan-m Start work on a new Main
ivan-m authored
72
5f53974 @ivan-m Re-write and update Main
ivan-m authored
73 data BuildTarget = GhcUpgrade
74 | DepCheck
38db99c @ivan-m Add an --all option to GHC
ivan-m authored
75 | AllInstalled
5f53974 @ivan-m Re-write and update Main
ivan-m authored
76 deriving (Eq, Ord, Show, Read)
f73cbd8 add option to only print install command
paczesiowa authored
77
38db99c @ivan-m Add an --all option to GHC
ivan-m authored
78 getPackages :: BuildTarget -> IO [Package]
79 getPackages GhcUpgrade = oldGhcPkgs
80 getPackages DepCheck = brokenPkgs
81 getPackages AllInstalled = allInstalledPackages
f73cbd8 add option to only print install command
paczesiowa authored
82
5f53974 @ivan-m Re-write and update Main
ivan-m authored
83 allGetPackages :: Set BuildTarget -> IO [Package]
6634bf4 @ivan-m An attempt at being lazier for allGetPackages
ivan-m authored
84 allGetPackages = liftM nub
85 . concatMapM getPackages
5f53974 @ivan-m Re-write and update Main
ivan-m authored
86 . Set.toList
f73cbd8 add option to only print install command
paczesiowa authored
87
5f53974 @ivan-m Re-write and update Main
ivan-m authored
88 -- -----------------------------------------------------------------------------
89 -- How to build packages.
90
91 data RunModifier = RM { pkgmgr :: PkgManager
92 , flags :: [PMFlag]
93 , withCmd :: WithCmd
d36b9f8 @trofi added support for passing arbitrary options to PM command ('--' separ…
trofi authored
94 , rawPMArgs :: [String]
5f53974 @ivan-m Re-write and update Main
ivan-m authored
95 }
96 deriving (Eq, Ord, Show, Read)
97
98 -- At the moment, PrintAndRun is the only option available.
99 data WithCmd = RunOnly
100 | PrintOnly
101 | PrintAndRun
102 deriving (Eq, Ord, Show, Read)
103
942eef3 @trofi commandline: inhibit shell expansion of passed arguments
trofi authored
104 runCmd :: WithCmd -> String -> [String] -> IO a
105 runCmd mode cmd args = case mode of
106 RunOnly -> runCommand cmd args
107 PrintOnly -> success cmd_line
108 PrintAndRun -> putStrLn cmd_line >> runCommand cmd args
109 where cmd_line = unwords (cmd:args)
5f53974 @ivan-m Re-write and update Main
ivan-m authored
110
942eef3 @trofi commandline: inhibit shell expansion of passed arguments
trofi authored
111 runCommand :: String -> [String] -> IO a
112 runCommand cmd args = rawSystem cmd args >>= exitWith
5f53974 @ivan-m Re-write and update Main
ivan-m authored
113
114 buildPkgs :: RunModifier -> [Package] -> IO a
115 buildPkgs _ [] = success "\nNothing to build!"
942eef3 @trofi commandline: inhibit shell expansion of passed arguments
trofi authored
116 buildPkgs rm ps = runCmd (withCmd rm) cmd args
5f53974 @ivan-m Re-write and update Main
ivan-m authored
117 where
942eef3 @trofi commandline: inhibit shell expansion of passed arguments
trofi authored
118 (cmd, args) = buildCmd (pkgmgr rm) (flags rm) (rawPMArgs rm) ps
b4b9cbd @ivan-m Documentation and re-organisation
ivan-m authored
119
120 -- -----------------------------------------------------------------------------
5f53974 @ivan-m Re-write and update Main
ivan-m authored
121 -- Command-line flags
122
123 data Flag = HelpFlag
124 | VersionFlag
125 | PM String
d1b3fd5 @jkarlson Add support for custom package manager command flag.
jkarlson authored
126 | CustomPMFlag String
5f53974 @ivan-m Re-write and update Main
ivan-m authored
127 | Check
128 | Upgrade
38db99c @ivan-m Add an --all option to GHC
ivan-m authored
129 | RebuildAll
5f53974 @ivan-m Re-write and update Main
ivan-m authored
130 | Pretend
bc6214c @trofi cleanup: changed tab to space
trofi authored
131 | NoDeep
5f53974 @ivan-m Re-write and update Main
ivan-m authored
132 deriving (Eq, Ord, Show, Read)
b4b9cbd @ivan-m Documentation and re-organisation
ivan-m authored
133
5f53974 @ivan-m Re-write and update Main
ivan-m authored
134 parseArgs :: IO (RunModifier, Action)
97cadd4 @ivan-m Argument parsing now done
ivan-m authored
135 parseArgs = do args <- getArgs
e75fe10 @ivan-m If the environment variable PACKAGE_MANAGER exists, default to that.
ivan-m authored
136 defPM <- defaultPM
d36b9f8 @trofi added support for passing arbitrary options to PM command ('--' separ…
trofi authored
137 argParser defPM $ getOpt' Permute options args
e75fe10 @ivan-m If the environment variable PACKAGE_MANAGER exists, default to that.
ivan-m authored
138
d36b9f8 @trofi added support for passing arbitrary options to PM command ('--' separ…
trofi authored
139 argParser :: PkgManager -> ([Flag], [String], [String], [String])
e75fe10 @ivan-m If the environment variable PACKAGE_MANAGER exists, default to that.
ivan-m authored
140 -> IO (RunModifier, Action)
d36b9f8 @trofi added support for passing arbitrary options to PM command ('--' separ…
trofi authored
141 argParser dPM (fls, nonoptions, unrecognized, []) =
142 do unless (null unrecognized)
d00bfa5 @trofi options: treat unknown commandline options as fatal errors
trofi authored
143 $ die $ unwords $ "Unknown options:" : unrecognized
d36b9f8 @trofi added support for passing arbitrary options to PM command ('--' separ…
trofi authored
144 unless (null bPms)
d00bfa5 @trofi options: treat unknown commandline options as fatal errors
trofi authored
145 $ die $ unwords $ "Unknown package managers:" : bPms
d36b9f8 @trofi added support for passing arbitrary options to PM command ('--' separ…
trofi authored
146 return (rm, a)
5f53974 @ivan-m Re-write and update Main
ivan-m authored
147 where
148 (fls', as) = partitionBy flagToAction fls
149 a = combineAllActions as
150 (opts, pms) = partitionBy flagToPM fls'
d1b3fd5 @jkarlson Add support for custom package manager command flag.
jkarlson authored
151 (bPms, pms') = partitionBy isValidPM pms
e75fe10 @ivan-m If the environment variable PACKAGE_MANAGER exists, default to that.
ivan-m authored
152 pm = emptyElse dPM last pms'
5f53974 @ivan-m Re-write and update Main
ivan-m authored
153 opts' = Set.fromList opts
154 hasFlag = flip Set.member opts'
155 pmFlags = bool id (PretendBuild:) (hasFlag Pretend)
156 . return $ bool UpdateDeep UpdateAsNeeded (hasFlag NoDeep)
157 rm = RM { pkgmgr = pm
158 , flags = pmFlags
159 -- We need to get Flags that represent this as well.
160 , withCmd = PrintAndRun
d36b9f8 @trofi added support for passing arbitrary options to PM command ('--' separ…
trofi authored
161 , rawPMArgs = nonoptions
5f53974 @ivan-m Re-write and update Main
ivan-m authored
162 }
ae3bfa5 @ivan-m Abstract out hasFlag
ivan-m authored
163
d36b9f8 @trofi added support for passing arbitrary options to PM command ('--' separ…
trofi authored
164 argParser _ (_, _, _, errs) = die $ unwords $ "Errors in arguments:" : errs
31fe312 restructure rebuild actions
paczesiowa authored
165
5f53974 @ivan-m Re-write and update Main
ivan-m authored
166 flagToAction :: Flag -> Either Flag Action
167 flagToAction HelpFlag = Right Help
168 flagToAction VersionFlag = Right Version
169 flagToAction Check = Right . Build $ Set.singleton DepCheck
170 flagToAction Upgrade = Right . Build $ Set.singleton GhcUpgrade
38db99c @ivan-m Add an --all option to GHC
ivan-m authored
171 flagToAction RebuildAll = Right . Build $ Set.singleton AllInstalled
5f53974 @ivan-m Re-write and update Main
ivan-m authored
172 flagToAction f = Left f
97cadd4 @ivan-m Argument parsing now done
ivan-m authored
173
d1b3fd5 @jkarlson Add support for custom package manager command flag.
jkarlson authored
174 flagToPM :: Flag -> Either Flag PkgManager
175 flagToPM (CustomPMFlag pm) = Right $ stringToCustomPM pm
176 flagToPM (PM pm) = Right $ choosePM pm
177 flagToPM f = Left f
97cadd4 @ivan-m Argument parsing now done
ivan-m authored
178
5f53974 @ivan-m Re-write and update Main
ivan-m authored
179 options :: [OptDescr Flag]
180 options =
181 [ Option ['c'] ["dep-check"] (NoArg Check)
182 "Check dependencies of Haskell packages."
183 , Option ['u'] ["upgrade"] (NoArg Upgrade)
184 "Rebuild Haskell packages after a GHC upgrade."
38db99c @ivan-m Add an --all option to GHC
ivan-m authored
185 , Option [] ["all"] (NoArg RebuildAll)
186 "Rebuild all Haskell libraries built with current GHC."
5f53974 @ivan-m Re-write and update Main
ivan-m authored
187 , Option ['P'] ["package-manager"] (ReqArg PM "PM")
188 $ "Use package manager PM, where PM can be one of:\n"
189 ++ pmList ++ defPM
eae1ca0 @trofi --help: use '--custom-pm' instead of '----custom-pm'
trofi authored
190 , Option ['C'] ["custom-pm"] (ReqArg CustomPMFlag "command")
1f74edb @ivan-m Improve custom PM message to state it ignores extra flags.
ivan-m authored
191 "Use custom command as package manager;\n\
192 \ignores the --pretend and --no-deep flags."
5f53974 @ivan-m Re-write and update Main
ivan-m authored
193 , Option ['p'] ["pretend"] (NoArg Pretend)
194 "Only pretend to build packages."
195 , Option [] ["no-deep"] (NoArg NoDeep)
196 "Don't pull deep dependencies (--deep with emerge)."
197 , Option ['v'] ["version"] (NoArg VersionFlag)
198 "Version information."
199 , Option ['h', '?'] ["help"] (NoArg HelpFlag)
200 "Print this help message."
201 ]
202 where
203 pmList = unlines . map ((++) " * ") $ definedPMs
204 defPM = "The last valid value of PM specified is chosen.\n\
e75fe10 @ivan-m If the environment variable PACKAGE_MANAGER exists, default to that.
ivan-m authored
205 \The default package manager is: " ++ defaultPMName ++ ",\n\
206 \which can be overriden with the \"PACKAGE_MANAGER\"\n\
207 \environment variable."
5f53974 @ivan-m Re-write and update Main
ivan-m authored
208
209 -- -----------------------------------------------------------------------------
210 -- Printing information.
97cadd4 @ivan-m Argument parsing now done
ivan-m authored
211
050bddb @ivan-m Replace all "IO ExitCode" with "IO a"
ivan-m authored
212 help :: IO a
f69c425 @ivan-m Create die, and use success and die for help and err
ivan-m authored
213 help = progInfo >>= success
214
1b22875 Implement --version
Stephan Friedrichs authored
215 version :: IO a
f3f8aa1 @ivan-m Add helper printouts, etc. saying what haskell-updater is doing.
ivan-m authored
216 version = fmap (++ '-' : showVersion Paths.version) getProgName >>= success
1b22875 Implement --version
Stephan Friedrichs authored
217
050bddb @ivan-m Replace all "IO ExitCode" with "IO a"
ivan-m authored
218 err :: String -> IO a
f69c425 @ivan-m Create die, and use success and die for help and err
ivan-m authored
219 err msg = liftM addMsg progInfo >>= die
220 where
221 addMsg str = msg ++ "\n\n"++ str
222
1682295 @ivan-m Define information on program usage
ivan-m authored
223 progInfo :: IO String
95432aa @ivan-m Avoid shadowing existing bindings for name
ivan-m authored
224 progInfo = do pName <- getProgName
225 return $ usageInfo (header pName) options
1682295 @ivan-m Define information on program usage
ivan-m authored
226 where
95432aa @ivan-m Avoid shadowing existing bindings for name
ivan-m authored
227 header pName = pName ++ " -- Find and rebuild packages broken due to either:\n\
1682295 @ivan-m Define information on program usage
ivan-m authored
228 \ * GHC upgrade\n\
229 \ * Haskell dependency upgrade\n\
bf27213 @ivan-m Replace --check with --dep-check, update usage docs.
ivan-m authored
230 \ Default action is to do both.\n\
1682295 @ivan-m Define information on program usage
ivan-m authored
231 \\n\
d36b9f8 @trofi added support for passing arbitrary options to PM command ('--' separ…
trofi authored
232 \Usage: " ++ pName ++ " [Options [-- [PM options]]\n\
1682295 @ivan-m Define information on program usage
ivan-m authored
233 \\n\
234 \\n\
235 \Options:"
236
fcd0508 @ivan-m Specify with the other information which package manager is being used.
ivan-m authored
237 systemInfo :: RunModifier -> IO ()
238 systemInfo rm = do ver <- ghcVersion
239 pName <- getProgName
240 pLoc <- ghcLoc
241 libDir <- ghcLibDir
242 putStrLn $ "Running " ++ pName ++ " using GHC " ++ ver
243 putStrLn $ " * Executable: " ++ pLoc
244 putStrLn $ " * Library directory: " ++ libDir
d36b9f8 @trofi added support for passing arbitrary options to PM command ('--' separ…
trofi authored
245 putStrLn $ " * Package manager (PM): " ++ nameOfPM (pkgmgr rm)
246 unless (null (rawPMArgs rm)) $
247 putStrLn $ " * PM auxiliary arguments: " ++ unwords (rawPMArgs rm)
fcd0508 @ivan-m Specify with the other information which package manager is being used.
ivan-m authored
248 putStrLn ""
5f53974 @ivan-m Re-write and update Main
ivan-m authored
249
b4b9cbd @ivan-m Documentation and re-organisation
ivan-m authored
250 -- -----------------------------------------------------------------------------
5f53974 @ivan-m Re-write and update Main
ivan-m authored
251 -- Utility functions
b4b9cbd @ivan-m Documentation and re-organisation
ivan-m authored
252
5f53974 @ivan-m Re-write and update Main
ivan-m authored
253 success :: String -> IO a
254 success msg = do putStrLn msg
255 exitWith ExitSuccess
b4b9cbd @ivan-m Documentation and re-organisation
ivan-m authored
256
5f53974 @ivan-m Re-write and update Main
ivan-m authored
257 die :: String -> IO a
d00bfa5 @trofi options: treat unknown commandline options as fatal errors
trofi authored
258 die msg = do putErrLn ("ERROR: " ++ msg)
5f53974 @ivan-m Re-write and update Main
ivan-m authored
259 exitWith (ExitFailure 1)
9503df8 @ivan-m Rollback paczesiowa's patches
ivan-m authored
260
5f53974 @ivan-m Re-write and update Main
ivan-m authored
261 putErrLn :: String -> IO ()
262 putErrLn = hPutStrLn stderr
1682295 @ivan-m Define information on program usage
ivan-m authored
263
5f53974 @ivan-m Re-write and update Main
ivan-m authored
264 bool :: a -> a -> Bool -> a
265 bool f t b = if b then t else f
266
267 partitionBy :: (a -> Either l r) -> [a] -> ([l], [r])
268 partitionBy f = partitionEithers . map f
269
270 -- If the list is empty, return the provided value; otherwise use the function.
271 emptyElse :: b -> ([a] -> b) -> [a] -> b
272 emptyElse e _ [] = e
273 emptyElse _ f as = f as
Something went wrong with that request. Please try again.