465a7576cc3fc87a6901ff3ec7b9b112fb76d7bc
[barrelfish] / hake / Main.hs
1 {- 
2   Hake: a meta build system for Barrelfish
3
4   Copyright (c) 2009, ETH Zurich.
5   All rights reserved.
6   
7   This file is distributed under the terms in the attached LICENSE file.
8   If you do not find this file, copies can be found by writing to:
9   ETH Zurich D-INFK, Haldeneggsteig 4, CH-8092 Zurich. Attn: Systems Group.
10 -}
11   
12
13
14 module Main where
15
16 import System.Environment
17 import System.IO
18 import System.Directory
19 import System.Exit
20 import GHC hiding (Target)
21 import GHC.Paths ( libdir )
22 import DynFlags ( defaultDynFlags )
23 import Data.Dynamic
24 import Data.Maybe
25 import Data.List
26 import Control.Monad
27
28 import RuleDefs
29 import HakeTypes
30 import qualified Path
31 import qualified Args
32 import qualified Config
33
34 --
35 -- Command line options and parsing code
36 --
37 data Opts = Opts { opt_makefilename :: String,
38                    opt_installdir :: String,
39                    opt_sourcedir :: String,
40                    opt_bfsourcedir :: String,
41                    opt_usage_error :: Bool,
42                    opt_architectures :: [String],
43                    opt_verbosity :: Integer
44                  }
45           deriving (Show,Eq)
46                    
47 parse_arguments :: [String] -> Opts
48 parse_arguments [] =
49   Opts { opt_makefilename = "Makefile",
50          opt_installdir = Config.install_dir,
51          opt_sourcedir = Config.source_dir,
52          opt_bfsourcedir = Config.source_dir,
53          opt_usage_error = False, 
54          opt_architectures = [],
55          opt_verbosity = 1 }
56 parse_arguments ("--install-dir" : (s : t)) =
57   (parse_arguments t) { opt_installdir = s }
58 parse_arguments ("--source-dir" : s : t) =  
59   (parse_arguments t) { opt_sourcedir = s }
60 parse_arguments ("--bfsource-dir" : s : t) =  
61   (parse_arguments t) { opt_bfsourcedir = s }
62 parse_arguments ("--output-filename" : s : t) =
63   (parse_arguments t) { opt_makefilename = s }
64 parse_arguments ("--quiet" : t ) = 
65   (parse_arguments t) { opt_verbosity = 0 }
66 parse_arguments ("--verbose" : t ) = 
67   (parse_arguments t) { opt_verbosity = 2 }
68 parse_arguments ("--architecture" : a : t ) = 
69   let 
70     o2 = parse_arguments t
71     arches = (a : opt_architectures o2)
72   in
73     o2 { opt_architectures = arches }
74 parse_arguments _ = 
75   (parse_arguments []) { opt_usage_error = True }
76
77 usage :: String
78 usage = unlines [ "Usage: hake <options>",
79                   "   --source-dir <dir> (required)",
80                   "   --bfsource-dir <dir> (defaults to source dir)",
81                   "   --install-dir <dir> (defaults to source dir)",
82                   "   --quiet",
83                   "   --verbose"
84                 ]
85
86 --
87 -- Handy path operator
88 --
89 infix 4 ./.
90 root ./. path = Path.relToDir path root
91
92
93 --
94 -- Walk all over a directory tree and build a complete list of pathnames
95 --
96 listFilesR :: FilePath -> IO [FilePath]
97 listFilesR path = let
98     isDODD :: String -> Bool
99     isDODD f = not $ (isSuffixOf "/." f) 
100                   || (isSuffixOf "/.." f) 
101                   || (isSuffixOf "/.hg" f)
102                   || (isSuffixOf "CMakeFiles" f)
103                   || (isPrefixOf "./build" f)
104
105     listDirs :: [FilePath] -> IO [FilePath]
106     listDirs = filterM doesDirectoryExist 
107
108     listFiles :: [FilePath] -> IO [FilePath]
109     listFiles = filterM doesFileExist
110
111     joinFN :: String -> String -> FilePath
112     -- joinFN p1 p2 = joinPath [p1, p2]
113     joinFN p1 p2 =  p1 ++ "/" ++ p2
114
115     in do
116         allfiles <- getDirectoryContents path
117         no_dots <- filterM (return . isDODD) (map (joinFN path) allfiles)
118         dirs <- listDirs no_dots
119         subdirfiles <- (mapM listFilesR dirs >>= return . concat)
120         files <- listFiles no_dots
121         return $ files ++ subdirfiles
122
123 --
124 -- Return a list of pairs of (Hakefile name, contents)
125 -- 
126 readHakeFiles :: [FilePath] -> IO [ (String,String) ]
127 readHakeFiles [] = return []
128 readHakeFiles (h:hs) = do { r <- readFile h; 
129                             rs <- readHakeFiles hs;
130                             return ((h,r):rs)
131                           }
132 --
133 -- Look for Hakefiles in a list of path names
134 --
135 hakeFiles :: [FilePath] -> [String]
136 hakeFiles f = [ fp | fp <- f, isSuffixOf "/Hakefile" fp ]
137
138 ---
139 --- Functions to resolve relative path names in rules. 
140 ---
141 --- First, the outer function: resolve path names in an HRule. The
142 --- third argument, 'root', is frequently the pathname of the Hakefile
143 --- relative to the source tree - since relative pathnames in
144 --- Hakefiles are interpreted relative to the Hakefile location.
145 ---
146 resolveRelativePaths :: Opts -> HRule -> String -> HRule
147 resolveRelativePaths o (Rules hrules) root 
148     = Rules [ resolveRelativePaths o r root | r <- hrules ]
149 resolveRelativePaths o (Rule tokens) root
150     = Rule [ resolveRelativePath o t root | t <- tokens ]
151 resolveRelativePaths o (Include token) root
152     = Include ( resolveRelativePath o token root )
153 resolveRelativePaths o (Error s) root 
154     = (Error s)
155
156
157 --- Now resolve at the level of individual rule tokens.  At this
158 --- level, we need to take into account the tree (source, build, or
159 --- install).
160 resolveRelativePath :: Opts -> RuleToken -> String -> RuleToken
161 resolveRelativePath o (In t a f) root = 
162     (In t a (resolveRelativePathName o t a f root))
163 resolveRelativePath o (Out a f) root = 
164     (Out a (resolveRelativePathName o BuildTree a f root))
165 resolveRelativePath o (Dep t a f) root = 
166     (Dep t a (resolveRelativePathName o t a f root))
167 resolveRelativePath o (NoDep t a f) root = 
168     (NoDep t a (resolveRelativePathName o t a f root))
169 resolveRelativePath o (PreDep t a f) root = 
170     (PreDep t a (resolveRelativePathName o t a f root))
171 resolveRelativePath o (Target a f) root = 
172     (Target a (resolveRelativePathName o BuildTree a f root))
173 resolveRelativePath _ (Str s) _ = (Str s)
174 resolveRelativePath _ (NStr s) _ = (NStr s)
175 resolveRelativePath _ (ContStr b s1 s2) _ = (ContStr b s1 s2)
176 resolveRelativePath _ (ErrorMsg s) _ = (ErrorMsg s)
177 resolveRelativePath _ NL _ = NL
178
179 --- Now we get down to the nitty gritty.  We have a tree (source,
180 --- build, or install), an architecture (e.g. ARM), a pathname, and
181 --- the pathname of the Hakefile in which it occurs.
182
183 resolveRelativePathName :: Opts -> TreeRef -> String -> String -> String -> String
184 resolveRelativePathName o InstallTree "root" f root = 
185     resolveRelativePathName' ((opt_installdir o)) "root" f root
186 resolveRelativePathName o _ "root" f root = 
187     "." ./. f
188 resolveRelativePathName o SrcTree a f root =
189     resolveRelativePathName' (opt_sourcedir o) a f root
190 resolveRelativePathName o BuildTree a f root =
191     resolveRelativePathName' ("." ./. a) a f root
192 resolveRelativePathName o InstallTree a f root =
193     resolveRelativePathName' ((opt_installdir o) ./. a) a f root
194
195 --- This is where the work is done: take 'root' (pathname relative to
196 --- us of the Hakefile) and resolve the filename we're interested in
197 --- relative to this.  This gives us a pathname relative to some root
198 --- of some architecture tree, then return this relative to the actual
199 --- tree we're interested in.  It's troubling that this takes more
200 --- bytes to explain than to code.
201 resolveRelativePathName' d a f root = 
202     let af = Path.relToFile f root
203         rf = Path.makeRel $ Path.relToDir af "/" 
204     in Path.relToDir rf d
205
206 --
207 -- Generating a list of build directories
208 --
209 makeDirectories :: [(String, HRule)] -> String
210 makeDirectories r = 
211     let alldirs = makeDirs1 (Rules [ rl | (f,rl) <- r ])
212         marker d = d ./. ".marker"
213     in unlines ([ "# Directories follow" ] ++
214                 [ "hake_dirs: " ++ (marker d) ++ "\n\n" ++
215                   (marker d) ++ ": \n" ++
216                   "\tmkdir -p " ++ d ++ "\n" ++
217                   "\ttouch " ++ (marker d) ++ "\n"
218                 | d <- nub alldirs])
219        
220 makeDirs1 :: HRule -> [String]
221 makeDirs1 (Rules hrules) = concat [ makeDirs1 r | r <- hrules]
222 makeDirs1 (Include tok) = 
223     case tokDir tok of
224       Nothing -> []
225       Just d -> [d]
226 makeDirs1 (Rule toks) = [d | Just d <- [ tokDir t | t <- toks ]]
227 makeDirs1 (Error s) = []
228
229 tokDir :: RuleToken -> Maybe String
230 tokDir (In t a f) = tokDir1 f
231 tokDir (Out a f) =  tokDir1 f
232 tokDir (Dep t a f) =  tokDir1 f
233 tokDir (NoDep t a f) =  tokDir1 f
234 tokDir (PreDep t a f) =  tokDir1 f
235 tokDir (Target a f) =  tokDir1 f
236 tokDir (Str s) = Nothing
237 tokDir (NStr s) = Nothing
238 tokDir (ContStr b s1 s2) = Nothing
239 tokDir (ErrorMsg s) = Nothing
240 tokDir NL = Nothing
241
242 tokDir1 f 
243     | (Path.dirname f) `Path.isBelow` "." = Just (Path.dirname f)
244     | otherwise = Nothing
245
246 --
247 -- filter rules by the set of architectures in Config.architectures
248 --
249 filterRuleByArch :: HRule -> Maybe HRule
250 filterRuleByArch (Rule toks) = if allowedArchs (map frArch toks) then Just (Rule toks) else Nothing
251 filterRuleByArch (Include tok) = if allowedArchs [frArch tok] then Just (Include tok) else Nothing
252 filterRuleByArch (Rules rules) = Just (Rules (catMaybes $ map filterRuleByArch rules))
253 filterRuleByArch x = Just x
254
255 -- a rule is included if it has only "special" architectures and enabled architectures
256 allowedArchs :: [String] -> Bool
257 allowedArchs = all (\a -> a `elem` (Config.architectures ++ specialArchitectures))
258     where specialArchitectures = ["", "src", "hake", "root", "tools", "docs"]
259
260 -- 
261 -- Functions to format rules as Makefile rules
262 --
263 makeMakefile :: [(String, HRule)] -> String
264 makeMakefile r = 
265   unlines $ intersperse "" [makeMakefileSection f rl | (f,rl) <- r]
266
267 makeMakefileSection :: String -> HRule -> String
268 makeMakefileSection fname rules = 
269     "# From: " ++ fname ++ "\n\n" ++ makeMakeRules rules
270
271 makeMakeRules :: HRule -> String
272 makeMakeRules (Rules hrules)
273     = unlines [ s | s <- [ makeMakeRules h | h <- hrules ], s /= "" ]
274 makeMakeRules (Include token) = unlines [
275     "ifeq ($(MAKECMDGOALS),clean)",
276     "else ifeq ($(MAKECMDGOALS),rehake)",
277     "else ifeq ($(MAKECMDGOALS),Makefile)",
278     "else",
279     "include " ++ (formatToken token),
280     "endif"]
281 makeMakeRules (Error s) = "$(error " ++ s ++ ")\n"
282 makeMakeRules (Rule tokens) = 
283     let outs = nub [ f | (Out a f) <- tokens ] ++ [ f | (Target a f) <- tokens ]
284         dirs = nub [ (Path.dirname f) ./. ".marker" | f <- outs ]
285         deps = nub [ f | (In t a f) <- tokens ] ++ [ f | (Dep t a f) <- tokens ] 
286         predeps = nub [ f | (PreDep t a f) <- tokens ] 
287         spaceSep :: [ String ] -> String
288         spaceSep sl = concat (intersperse " " sl)
289         ruleBody = (concat[ formatToken t | t <- tokens, inRule t ])
290     in if outs == [] then
291       ("# hake: omitted rule with no output: " ++ ruleBody)
292     else
293       (spaceSep outs) ++ ": " 
294       ++ 
295       -- It turns out that if you add 'dirs' here, in an attempt to
296       -- get Make to build the directories as well, it goes a bit
297       -- pear-shaped: whenever the directory "changes" it goes out of
298       -- date, so you end up rebuilding dependencies every time.
299       (spaceSep (deps ++ dirs)) 
300       ++ 
301       (if (predeps == []) then "" else " | " ++ spaceSep (predeps))
302       ++ "\n" 
303       ++
304       (if (ruleBody == "") then "" else "\t" ++ ruleBody ++ "\n")
305       
306
307 preamble :: Opts -> [String] -> String
308 preamble opts args = 
309     unlines ( [ "# This Makefile is generated by Hake.  Do not edit!",
310                 "# ",
311                 "# Hake was invoked with the following command line args:" ] ++
312               [ "#        " ++ a | a <- args ] ++
313               [ "# ",
314                 "SRCDIR=" ++ (opt_sourcedir opts),
315                 "HAKE_ARCHS=" ++ (concat $ intersperse " " Config.architectures),
316                 "include ./symbolic_targets.mk" ] )
317
318 stripSrcDir :: String -> String
319 stripSrcDir s = Path.removePrefix Config.source_dir s
320
321 hakeModule :: [String] -> [(String,String)] -> String
322 hakeModule allfiles hakefiles = 
323     let unqual_imports = ["RuleDefs", "HakeTypes", "Path", "Args"]
324         qual_imports = ["Config", "List" ]
325         relfiles = [ stripSrcDir f | f <- allfiles ]
326         wrap1 n c = wrapLet "build a" 
327                     ("(buildFunction a) allfiles " ++ (show n) ++ " a")
328                     c
329         wrap n c = "(" ++ (show n) ++ ", " 
330                    ++ wrapLet "find fn arg" 
331                           ("(fn allfiles " ++ (show n) ++ " arg)") 
332                           ("Rules (" ++ (wrap1 n c) ++ ")")
333                    ++ ")"
334         flatten :: [String] -> String
335         flatten s = foldl (++) "" (intersperse ",\n" s)
336         addHeader (fn,fc) = (fn, "{-# LINE 1 \"" ++ fn ++ "\" #-}\n" ++ fc)
337         files = flatten [ wrap (stripSrcDir fn) fc | (fn,fc) <- map addHeader hakefiles ]
338     in
339       unlines ( [ "module Hakefiles where {" ]
340                 ++
341                 [ "import " ++ i ++ ";" | i <- unqual_imports ]
342                 ++
343                 [ "import qualified " ++ i ++ ";" | i <- qual_imports ] 
344                 ++
345                 [ "allfiles = " ++ (show relfiles) ++ ";" ]
346                 ++ 
347                 [ "hf = [" ] 
348               ) ++ files ++ "];\n}"
349
350 wrapLet :: String -> String -> String -> String
351 wrapLet var expr body = 
352     "(let " ++ var ++ " = " ++ expr ++ " in\n" ++ body ++ ")"
353
354 evalHakeFiles :: Opts -> [String] -> [(String,String)] 
355               -> IO [(String,HRule)]
356 evalHakeFiles o allfiles hakefiles = 
357     let imports = [ "HakeTypes", "Hakefiles"]
358         all_imports = ["Prelude"] ++ imports
359         moddirs = [ (opt_installdir o) ./. "hake", 
360                     ".", 
361                     (opt_bfsourcedir o) ./. "hake" ]
362     in do 
363       defaultErrorHandler defaultDynFlags $ do 
364          runGhc (Just libdir) $ do
365            dflags <- getSessionDynFlags
366            setSessionDynFlags dflags { importPaths = moddirs,
367                 hiDir = Just "./hake",
368                 objectDir = Just "./hake",
369                 flags = Opt_DeriveDataTypeable:(flags dflags) }
370            targets <- mapM (\m -> guessTarget m Nothing) imports
371            setTargets targets
372            load LoadAllTargets
373            modlist <- mapM (\m -> findModule (mkModuleName m) Nothing) all_imports
374            setContext [] modlist
375            val <- dynCompileExpr "Hakefiles.hf :: [(String, HRule)]" 
376            return (fromDyn val [("failed",Error "failed")])
377
378 --
379 -- Generate dependencies of the Makefile on all the Hakefiles
380 --
381 --resolveRelativePaths o (Rules hrules) root 
382 --- resolveRelativePath o (In t a f) root = 
383 makeHakeDeps :: Opts -> [ String ] -> String
384 makeHakeDeps o l = 
385     let hake = resolveRelativePath o (In InstallTree "root" "/hake/hake") ""
386         makefile = resolveRelativePath o (Out "root" (opt_makefilename o)) "/Hakefile"
387         rule = Rule ( [ hake, 
388                         Str "--source-dir", Str (opt_sourcedir o),
389                         Str "--install-dir", Str (opt_installdir o),
390                         Str "--output-filename", makefile
391                       ] ++
392                       [ Dep SrcTree "root" h | h <- l ]
393                     )
394     in
395      (makeMakeRules rule)
396      ++ ".DELETE_ON_ERROR:\n\n" -- this applies to all targets in the Makefile
397
398 makeHakeDeps1 :: Opts -> [ String ] -> String
399 makeHakeDeps1 _ l = 
400     "Makefile: ./hake/hake " 
401     ++ concat (intersperse " " l)
402     ++ "\n\t./hake/hake Makefile\n"
403     ++ ".DELETE_ON_ERROR:\n\n" -- this applies to all targets in the Makefile
404
405 -- check the configuration options, returning an error string if they're insane
406 configErrors :: Maybe String
407 configErrors
408     | unknownArchs /= [] = Just ("unknown architecture(s) specified: "
409                                ++ (concat $ intersperse ", " unknownArchs))
410     | Config.architectures == [] = Just "no architectures defined"
411     | Config.lazy_thc && not Config.use_fp = Just "Config.use_fp must be true to use Config.lazy_thc."
412     | otherwise = Nothing
413     where
414     unknownArchs = Config.architectures \\ Args.allArchitectures
415
416
417 ---
418 --- Convert a Hakefile name to one relative to the root of the source tree. 
419 ---
420 strip_hfn :: Opts -> String -> String
421 strip_hfn opts f = Path.removePrefix (opt_sourcedir opts) f
422
423 main :: IO() 
424 main = do
425     -- parse arguments; architectures default to config file
426     args <- System.Environment.getArgs
427     let o1 = parse_arguments args
428         al = if opt_architectures o1 == [] 
429              then Config.architectures 
430              else opt_architectures o1
431         opts = o1 { opt_architectures = al }
432     if opt_usage_error opts then do
433         hPutStrLn stderr usage
434         exitWith $ ExitFailure 1
435       else do
436
437     -- sanity-check configuration settings
438     -- this is currently known at compile time, but might not always be!
439     if isJust configErrors then do
440         hPutStrLn stderr $ "Error in configuration: " ++ (fromJust configErrors)
441         exitWith $ ExitFailure 2    
442       else do
443
444     hPutStrLn stdout ("Source directory: " ++ opt_sourcedir opts)
445     hPutStrLn stdout ("BF Source directory: " ++ opt_bfsourcedir opts)
446     hPutStrLn stdout ("Install directory: " ++ opt_installdir opts)
447       
448     hPutStrLn stdout "Reading directory tree..."
449     l <- listFilesR (opt_sourcedir opts)
450     hPutStrLn stdout "Reading Hakefiles..."
451     hfl <- readHakeFiles $ hakeFiles l
452     hPutStrLn stdout "Writing HakeFile module..."
453     modf <- openFile ("Hakefiles.hs") WriteMode
454     hPutStrLn modf $ hakeModule l hfl
455     hClose modf
456     hPutStrLn stdout "Evaluating Hakefiles..."
457     inrules <- evalHakeFiles opts l hfl
458     hPutStrLn stdout "Done!"
459     -- filter out rules for unsupported architectures and resolve relative paths
460     let rules = 
461           ([(f, resolveRelativePaths opts (fromJust (filterRuleByArch rl)) (strip_hfn opts f))
462            | (f,rl) <- inrules, isJust (filterRuleByArch rl) ])
463     hPutStrLn stdout $ "Generating " ++ (opt_makefilename opts) ++ " - this may take some time (and RAM)..." 
464     makef <- openFile(opt_makefilename opts) WriteMode
465     hPutStrLn makef $ preamble opts args
466     -- let hfl2 = [ strip_hfn opts (fst h) | h <- hfl ]
467     hPutStrLn makef $ makeHakeDeps opts $ map fst hfl
468     hPutStrLn makef $ makeMakefile rules
469     hPutStrLn makef $ makeDirectories rules
470     hClose makef
471     exitWith ExitSuccess