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