Skip to content

HTTPS clone URL

Subversion checkout URL

You can clone with
or
.
Download ZIP
Newer
Older
100644 260 lines (216 sloc) 9.219 kB
b4b9cbd @ivan-m Documentation and re-organisation
ivan-m authored
1 {- |
2 Module : Main
3 Description : The haskell-updater executable
d89f60b @ivan-m Add Stephan Friedrichs (igel) as an Author and Copyright holder
ivan-m authored
4 Copyright : (c) Ivan Lazar Miljenovic, Stephan Friedrichs 2009
b4b9cbd @ivan-m Documentation and re-organisation
ivan-m authored
5 License : GPL-2 or later
6 Maintainer : Ivan.Miljenovic@gmail.com
7
8 The executable module of haskell-updater, which finds Haskell
9 packages to rebuild after a dep upgrade or a GHC upgrade.
10 -}
edcfb5f @ivan-m Start work on a new Main
ivan-m authored
11 module Main where
12
13 import Distribution.Gentoo.GHC
14 import Distribution.Gentoo.Packages
15 import Distribution.Gentoo.PkgManager
16
5f53974 @ivan-m Re-write and update Main
ivan-m authored
17 import Data.Either(partitionEithers)
18 import Data.List(foldl1')
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)
5f53974 @ivan-m Re-write and update Main
ivan-m authored
27 import Control.Monad(liftM, liftM2, unless)
becbf1c @ivan-m Re-write PkgManager
ivan-m authored
28 import System.Process(system)
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
66 runAction rm (Build ts) = do systemInfo
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
75 deriving (Eq, Ord, Show, Read)
f73cbd8 add option to only print install command
paczesiowa authored
76
5f53974 @ivan-m Re-write and update Main
ivan-m authored
77 getPackages :: BuildTarget -> IO [Package]
78 getPackages GhcUpgrade = oldGhcPkgs
79 getPackages DepCheck = brokenPkgs
f73cbd8 add option to only print install command
paczesiowa authored
80
5f53974 @ivan-m Re-write and update Main
ivan-m authored
81 getPackages' :: BuildTarget -> IO (Set Package)
82 getPackages' = liftM Set.fromList . getPackages
becbf1c @ivan-m Re-write PkgManager
ivan-m authored
83
5f53974 @ivan-m Re-write and update Main
ivan-m authored
84 allGetPackages :: Set BuildTarget -> IO [Package]
85 allGetPackages = liftM (Set.toList . Set.unions)
86 . mapM getPackages'
87 . Set.toList
f73cbd8 add option to only print install command
paczesiowa authored
88
5f53974 @ivan-m Re-write and update Main
ivan-m authored
89 -- -----------------------------------------------------------------------------
90 -- How to build packages.
91
92 data RunModifier = RM { pkgmgr :: PkgManager
93 , flags :: [PMFlag]
94 , withCmd :: WithCmd
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
104 runCmd :: WithCmd -> String -> IO a
105 runCmd RunOnly = runCommand
106 runCmd PrintOnly = success
107 runCmd PrintAndRun = liftM2 (>>) putStrLn runCommand
108
109 runCommand :: String -> IO a
110 runCommand cmd = system cmd >>= exitWith
111
112 buildPkgs :: RunModifier -> [Package] -> IO a
113 buildPkgs _ [] = success "\nNothing to build!"
114 buildPkgs rm ps = runCmd (withCmd rm) cmd
115 where
116 cmd = buildCmd (pkgmgr rm) (flags rm) ps
b4b9cbd @ivan-m Documentation and re-organisation
ivan-m authored
117
118 -- -----------------------------------------------------------------------------
5f53974 @ivan-m Re-write and update Main
ivan-m authored
119 -- Command-line flags
120
121 data Flag = HelpFlag
122 | VersionFlag
123 | PM String
124 | Check
125 | Upgrade
126 | Pretend
127 | NoDeep
128 deriving (Eq, Ord, Show, Read)
b4b9cbd @ivan-m Documentation and re-organisation
ivan-m authored
129
5f53974 @ivan-m Re-write and update Main
ivan-m authored
130 parseArgs :: IO (RunModifier, Action)
97cadd4 @ivan-m Argument parsing now done
ivan-m authored
131 parseArgs = do args <- getArgs
e75fe10 @ivan-m If the environment variable PACKAGE_MANAGER exists, default to that.
ivan-m authored
132 defPM <- defaultPM
133 argParser defPM $ getOpt Permute options args
134
135 argParser :: PkgManager -> ([Flag], [String], [String])
136 -> IO (RunModifier, Action)
137 argParser dPM (fls, oth, []) = do unless (null oth)
138 $ putErrLn
139 $ unwords $ "Unknown options:" : oth
140 unless (null bPms)
141 $ putErrLn
142 $ unwords $ "Unknown package managers:" : bPms
143 return (rm, a)
5f53974 @ivan-m Re-write and update Main
ivan-m authored
144 where
145 (fls', as) = partitionBy flagToAction fls
146 a = combineAllActions as
147 (opts, pms) = partitionBy flagToPM fls'
148 (bPms, pms') = partitionBy choosePM pms
e75fe10 @ivan-m If the environment variable PACKAGE_MANAGER exists, default to that.
ivan-m authored
149 pm = emptyElse dPM last pms'
5f53974 @ivan-m Re-write and update Main
ivan-m authored
150 opts' = Set.fromList opts
151 hasFlag = flip Set.member opts'
152 pmFlags = bool id (PretendBuild:) (hasFlag Pretend)
153 . return $ bool UpdateDeep UpdateAsNeeded (hasFlag NoDeep)
154 rm = RM { pkgmgr = pm
155 , flags = pmFlags
156 -- We need to get Flags that represent this as well.
157 , withCmd = PrintAndRun
158 }
ae3bfa5 @ivan-m Abstract out hasFlag
ivan-m authored
159
e75fe10 @ivan-m If the environment variable PACKAGE_MANAGER exists, default to that.
ivan-m authored
160 argParser _ (_, _, errs) = die $ unwords $ "Errors in arguments:" : errs
31fe312 restructure rebuild actions
paczesiowa authored
161
5f53974 @ivan-m Re-write and update Main
ivan-m authored
162 flagToAction :: Flag -> Either Flag Action
163 flagToAction HelpFlag = Right Help
164 flagToAction VersionFlag = Right Version
165 flagToAction Check = Right . Build $ Set.singleton DepCheck
166 flagToAction Upgrade = Right . Build $ Set.singleton GhcUpgrade
167 flagToAction f = Left f
97cadd4 @ivan-m Argument parsing now done
ivan-m authored
168
5f53974 @ivan-m Re-write and update Main
ivan-m authored
169 flagToPM :: Flag -> Either Flag String
170 flagToPM (PM pm) = Right pm
171 flagToPM f = Left f
97cadd4 @ivan-m Argument parsing now done
ivan-m authored
172
5f53974 @ivan-m Re-write and update Main
ivan-m authored
173 options :: [OptDescr Flag]
174 options =
175 [ Option ['c'] ["dep-check"] (NoArg Check)
176 "Check dependencies of Haskell packages."
177 , Option ['u'] ["upgrade"] (NoArg Upgrade)
178 "Rebuild Haskell packages after a GHC upgrade."
179 , Option ['P'] ["package-manager"] (ReqArg PM "PM")
180 $ "Use package manager PM, where PM can be one of:\n"
181 ++ pmList ++ defPM
182 , Option ['p'] ["pretend"] (NoArg Pretend)
183 "Only pretend to build packages."
184 , Option [] ["no-deep"] (NoArg NoDeep)
185 "Don't pull deep dependencies (--deep with emerge)."
186 , Option ['v'] ["version"] (NoArg VersionFlag)
187 "Version information."
188 , Option ['h', '?'] ["help"] (NoArg HelpFlag)
189 "Print this help message."
190 ]
191 where
192 pmList = unlines . map ((++) " * ") $ definedPMs
193 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
194 \The default package manager is: " ++ defaultPMName ++ ",\n\
195 \which can be overriden with the \"PACKAGE_MANAGER\"\n\
196 \environment variable."
5f53974 @ivan-m Re-write and update Main
ivan-m authored
197
198 -- -----------------------------------------------------------------------------
199 -- Printing information.
97cadd4 @ivan-m Argument parsing now done
ivan-m authored
200
050bddb @ivan-m Replace all "IO ExitCode" with "IO a"
ivan-m authored
201 help :: IO a
f69c425 @ivan-m Create die, and use success and die for help and err
ivan-m authored
202 help = progInfo >>= success
203
1b22875 Implement --version
Stephan Friedrichs authored
204 version :: IO a
f3f8aa1 @ivan-m Add helper printouts, etc. saying what haskell-updater is doing.
ivan-m authored
205 version = fmap (++ '-' : showVersion Paths.version) getProgName >>= success
1b22875 Implement --version
Stephan Friedrichs authored
206
050bddb @ivan-m Replace all "IO ExitCode" with "IO a"
ivan-m authored
207 err :: String -> IO a
f69c425 @ivan-m Create die, and use success and die for help and err
ivan-m authored
208 err msg = liftM addMsg progInfo >>= die
209 where
210 addMsg str = msg ++ "\n\n"++ str
211
1682295 @ivan-m Define information on program usage
ivan-m authored
212 progInfo :: IO String
95432aa @ivan-m Avoid shadowing existing bindings for name
ivan-m authored
213 progInfo = do pName <- getProgName
214 return $ usageInfo (header pName) options
1682295 @ivan-m Define information on program usage
ivan-m authored
215 where
95432aa @ivan-m Avoid shadowing existing bindings for name
ivan-m authored
216 header pName = pName ++ " -- Find and rebuild packages broken due to either:\n\
1682295 @ivan-m Define information on program usage
ivan-m authored
217 \ * GHC upgrade\n\
218 \ * Haskell dependency upgrade\n\
bf27213 @ivan-m Replace --check with --dep-check, update usage docs.
ivan-m authored
219 \ Default action is to do both.\n\
1682295 @ivan-m Define information on program usage
ivan-m authored
220 \\n\
95432aa @ivan-m Avoid shadowing existing bindings for name
ivan-m authored
221 \Usage: " ++ pName ++ " [Option]\n\
1682295 @ivan-m Define information on program usage
ivan-m authored
222 \\n\
223 \\n\
224 \Options:"
225
5f53974 @ivan-m Re-write and update Main
ivan-m authored
226 systemInfo :: IO ()
227 systemInfo = do ver <- ghcVersion
228 pName <- getProgName
229 pLoc <- ghcLoc
230 libDir <- ghcLibDir
231 putStrLn $ "Running " ++ pName ++ " using GHC " ++ ver
232 putStrLn $ " * Executable: " ++ pLoc
233 putStrLn $ " * Library directory: " ++ libDir
f2ea498 @ivan-m Clean up message printing for blank line usage
ivan-m authored
234 putStrLn ""
5f53974 @ivan-m Re-write and update Main
ivan-m authored
235
b4b9cbd @ivan-m Documentation and re-organisation
ivan-m authored
236 -- -----------------------------------------------------------------------------
5f53974 @ivan-m Re-write and update Main
ivan-m authored
237 -- Utility functions
b4b9cbd @ivan-m Documentation and re-organisation
ivan-m authored
238
5f53974 @ivan-m Re-write and update Main
ivan-m authored
239 success :: String -> IO a
240 success msg = do putStrLn msg
241 exitWith ExitSuccess
b4b9cbd @ivan-m Documentation and re-organisation
ivan-m authored
242
5f53974 @ivan-m Re-write and update Main
ivan-m authored
243 die :: String -> IO a
244 die msg = do putErrLn msg
245 exitWith (ExitFailure 1)
9503df8 @ivan-m Rollback paczesiowa's patches
ivan-m authored
246
5f53974 @ivan-m Re-write and update Main
ivan-m authored
247 putErrLn :: String -> IO ()
248 putErrLn = hPutStrLn stderr
1682295 @ivan-m Define information on program usage
ivan-m authored
249
5f53974 @ivan-m Re-write and update Main
ivan-m authored
250 bool :: a -> a -> Bool -> a
251 bool f t b = if b then t else f
252
253 partitionBy :: (a -> Either l r) -> [a] -> ([l], [r])
254 partitionBy f = partitionEithers . map f
255
256 -- If the list is empty, return the provided value; otherwise use the function.
257 emptyElse :: b -> ([a] -> b) -> [a] -> b
258 emptyElse e _ [] = e
259 emptyElse _ f as = f as
Something went wrong with that request. Please try again.