Better description of hake phases
[barrelfish] / hake / Main.hs
1 {- 
2   Hake: a meta build system for Barrelfish
3
4   Copyright (c) 2009, 2015, 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 -- Asynchronous IO for walking directories
13 import Control.Concurrent.Async
14
15 import Control.Monad.Error
16
17 import Data.Dynamic
18 import Data.List
19 import Data.Maybe
20 import qualified Data.Set as S
21
22 import System.Directory
23 import System.Environment
24 import System.Exit
25 import System.FilePath
26 import System.IO
27
28 -- The GHC API.  We use the mtl-compatible version in order to use liftIO
29 -- within the GHC monad.
30 import GHC hiding (Target, Ghc, runGhc, FunBind, Match)
31 import GHC.Paths (libdir)
32 import Control.Monad.Ghc
33 import DynFlags (defaultFatalMessager, defaultFlushOut,
34                  xopt_set, ExtensionFlag(Opt_DeriveDataTypeable,
35                                          Opt_StandaloneDeriving))
36
37 -- We parse and pretty-print Hakefiles.
38 import Language.Haskell.Exts
39
40 -- Hake components
41 import RuleDefs
42 import HakeTypes
43 import qualified Args
44 import qualified Config
45 import TreeDB
46
47 data HakeError = HakeError String Int
48 instance Error HakeError
49 type HakeMonad = ErrorT HakeError IO
50
51 --
52 -- Command line options and parsing code
53 --
54 data Opts = Opts { opt_makefilename :: String,
55                    opt_installdir :: String,
56                    opt_sourcedir :: String,
57                    opt_bfsourcedir :: String,
58                    opt_abs_installdir :: String,
59                    opt_abs_sourcedir :: String,
60                    opt_abs_bfsourcedir :: String,
61                    opt_usage_error :: Bool,
62                    opt_architectures :: [String],
63                    opt_verbosity :: Integer
64                  }
65           deriving (Show,Eq)
66                    
67 parse_arguments :: [String] -> Opts
68 parse_arguments [] =
69   Opts { opt_makefilename = "Makefile",
70          opt_installdir = Config.install_dir,
71          opt_sourcedir = Config.source_dir,
72          opt_bfsourcedir = Config.source_dir,
73          opt_abs_installdir = "",
74          opt_abs_sourcedir = "",
75          opt_abs_bfsourcedir = "",
76          opt_usage_error = False, 
77          opt_architectures = [],
78          opt_verbosity = 1 }
79 parse_arguments ("--install-dir" : (s : t)) =
80   (parse_arguments t) { opt_installdir = s }
81 parse_arguments ("--source-dir" : s : t) =  
82   (parse_arguments t) { opt_sourcedir = s }
83 parse_arguments ("--bfsource-dir" : s : t) =  
84   (parse_arguments t) { opt_bfsourcedir = s }
85 parse_arguments ("--output-filename" : s : t) =
86   (parse_arguments t) { opt_makefilename = s }
87 parse_arguments ("--quiet" : t ) = 
88   (parse_arguments t) { opt_verbosity = 0 }
89 parse_arguments ("--verbose" : t ) = 
90   (parse_arguments t) { opt_verbosity = 2 }
91 parse_arguments ("--architecture" : a : t ) = 
92   let 
93     o2 = parse_arguments t
94     arches = (a : opt_architectures o2)
95   in
96     o2 { opt_architectures = arches }
97 parse_arguments _ = 
98   (parse_arguments []) { opt_usage_error = True }
99
100 usage :: String
101 usage = unlines [ "Usage: hake <options>",
102                   "   --source-dir <dir> (required)",
103                   "   --bfsource-dir <dir> (defaults to source dir)",
104                   "   --install-dir <dir> (defaults to source dir)",
105                   "   --quiet",
106                   "   --verbose"
107                 ]
108
109 -- Check the configuration options, returning an error string if they're
110 -- invalid.
111 configErrors :: Maybe String
112 configErrors
113     | unknownArchs /= [] =
114         Just ("unknown architecture(s) specified: " ++
115         (concat $ intersperse ", " unknownArchs))
116     | Config.architectures == [] =
117         Just "no architectures defined"
118     | Config.lazy_thc && not Config.use_fp =
119         Just "Config.use_fp must be true to use Config.lazy_thc."
120     | otherwise =
121         Nothing
122     where
123         unknownArchs = Config.architectures \\ Args.allArchitectures
124
125 -- Walk the source tree and build a complete list of pathnames, loading any
126 -- Hakefiles.
127 listFiles :: FilePath -> IO ([FilePath], [(FilePath, String)])
128 listFiles root = listFiles' root root
129
130 listFiles' :: FilePath -> FilePath -> IO ([FilePath], [(FilePath, String)])
131 listFiles' root current
132     | ignore (takeFileName current) = return ([], [])
133     | otherwise = do
134         isdir <- doesDirectoryExist current
135         if isdir then do
136             children <- getDirectoryContents current
137             walkchildren children
138         else do
139             hake <- maybeHake current
140             return ([makeRelative root current], hake)
141     where
142         -- Walk the child directories in parallel.  This speeds things up
143         -- dramatically over NFS, with its high latency.
144         walkchildren :: [FilePath] -> IO ([FilePath], [(FilePath, String)])
145         walkchildren children = do
146             children_async <- mapM (async.walkchild) children
147             results <- mapM wait children_async
148             return $ joinResults results
149
150         joinResults :: [([a],[b])] -> ([a],[b])
151         joinResults [] = ([],[])
152         joinResults ((as,bs):xs) =
153             let (as',bs') = joinResults xs in
154                 (as ++ as', bs ++ bs')
155
156         walkchild :: FilePath -> IO ([FilePath], [(FilePath, String)])
157         walkchild child = listFiles' root (current </> child)
158
159         -- Load Hakfiles eagerly.  This amounts to <1MB for Barrelfish (2015).
160         maybeHake path
161             | takeFileName path == "Hakefile" = do
162                 contents <- readFile path
163                 return [(path, contents)]
164             | otherwise = return []
165
166         -- Don't descend into revision-control or build directories.
167         ignore :: FilePath -> Bool
168         ignore "."          = True
169         ignore ".."         = True
170         ignore "CMakeFiles" = True
171         ignore ".hg"        = True
172         ignore ".git"       = True
173         ignore "build"      = True
174         ignore _            = False
175
176 --
177 -- Hake parsing using the GHC API
178 --
179
180 -- We invoke GHC to parse the Hakefiles in a preconfigured environment,
181 -- to implement the Hake DSL.
182 evalHakeFiles :: Handle -> Opts -> TreeDB -> [(FilePath, String)] ->
183                  IO (S.Set FilePath)
184 evalHakeFiles makefile o srcDB hakefiles =
185     defaultErrorHandler defaultFatalMessager defaultFlushOut $
186         runGhc (Just libdir) $
187         driveGhc makefile o srcDB hakefiles
188
189 -- This is the code that executes in the GHC monad.
190 driveGhc :: Handle -> Opts -> TreeDB -> [(FilePath, String)] ->
191             Ghc (S.Set FilePath)
192 driveGhc makefile o srcDB hakefiles = do
193     -- Set the RTS flags
194     dflags <- getSessionDynFlags
195     let dflags' = foldl xopt_set dflags [ Opt_DeriveDataTypeable,
196                                           Opt_StandaloneDeriving ]
197     _ <- setSessionDynFlags dflags'{
198         importPaths = module_paths,
199         hiDir = Just "./hake",
200         objectDir = Just "./hake"
201     }
202
203     -- Set compilation targets i.e. everything that needs to be built from
204     -- source (*.hs).
205     targets <- mapM (\m -> guessTarget m Nothing) source_modules
206     setTargets targets
207     load LoadAllTargets
208
209     -- Import both system and Hake modules.
210     setContext
211         ([IIDecl $ simpleImportDecl $ mkModuleName m |
212             m <- modules] ++
213          [IIDecl $ (simpleImportDecl $ mkModuleName m) {
214                 ideclQualified = True
215           } | m <- qualified_modules])
216
217     -- Emit Makefile sections corresponding to Hakefiles
218     buildSections hakefiles
219
220     where
221         module_paths = [ (opt_installdir o) </> "hake", ".", 
222                          (opt_bfsourcedir o) </> "hake" ]
223         source_modules = [ "HakeTypes", "RuleDefs", "Args", "Config",
224                            "TreeDB" ]
225         modules = [ "Prelude", "System.FilePath", "HakeTypes", "RuleDefs",
226                     "Args", "TreeDB"  ]
227         qualified_modules = [ "Config", "Data.List" ]
228
229         -- Evaluate one Hakefile, and emit its Makefile section.  We collect
230         -- referenced directories as we go, to generate the 'directories'
231         -- rules later.
232         buildSections' :: (S.Set FilePath) -> [(FilePath, String)] ->
233                           Ghc (S.Set FilePath)
234         buildSections' dirs [] = return dirs
235         buildSections' dirs ((abs_hakepath, contents):hs) = do
236             let hakepath = makeRelative (opt_sourcedir o) abs_hakepath
237             rule <- evaluate hakepath contents
238             dirs' <- liftIO $ makefileSection makefile o hakepath rule
239             buildSections' (S.union dirs' dirs) hs
240
241         buildSections :: [(FilePath, String)] -> Ghc (S.Set FilePath)
242         buildSections hs = buildSections' S.empty hs
243
244         -- Evaluate a Hakefile, returning something of the form
245         -- Rule [...]
246         evaluate :: FilePath -> String -> Ghc HRule
247         evaluate hakepath hake_raw = do
248             case hake_parse of
249                 Left hake_expr -> do
250                     let hake_wrapped =
251                             prettyPrintWithMode (defaultMode {layout = PPNoLayout}) $
252                                 wrapHake hakepath hake_expr
253
254                     -- Evaluate in GHC
255                     val <- dynCompileExpr $ hake_wrapped ++
256                                             " :: TreeDB -> HRule"
257                     let rule = fromDyn val (\_ -> Error "failed")
258
259                     -- Path resolution
260                     let resolved_rule =
261                             resolvePaths o (takeDirectory hakepath)
262                                            (rule srcDB)
263                     return resolved_rule
264                 Right hake_error -> do
265                     return $ Error "failed"
266             where
267                 hake_parse = parseHake hakepath hake_raw
268
269 -- Parse a Hakefile, prior to wrapping it with Hake definitions
270 parseHake :: FilePath -> String -> Either Exp HakeError
271 parseHake filename contents =
272     case result of
273         ParseOk e -> Left e
274         ParseFailed loc str ->
275             Right $ HakeError (show loc ++ ": " ++ str) 2
276     where
277         result =
278             parseExpWithMode
279                 (defaultParseMode {
280                     parseFilename = filename,
281                     baseLanguage = Haskell2010 })
282                 contents
283
284 -- Split a Hake rule up by token type.  It's more efficient to do this
285 -- in a single pass, than to filter each as it's required.
286 data CompiledRule =
287     CompiledRule {
288         ruleOutputs    :: S.Set RuleToken,
289         ruleDepends    :: S.Set RuleToken,
290         rulePreDepends :: S.Set RuleToken,
291         ruleBody       :: [RuleToken],
292         ruleDirs       :: S.Set FilePath
293     }
294
295 compileRule :: [RuleToken] -> CompiledRule
296 compileRule [] = CompiledRule S.empty  S.empty  S.empty  []  S.empty
297 compileRule (t:ts) =
298     let CompiledRule outs deps predeps body dirs = compileRule ts
299         outs'    = if isOutput t then S.insert t outs else outs
300         deps'    = if isDependency t then S.insert t deps else deps
301         predeps' = if isPredependency t then S.insert t predeps else predeps
302         body'    = if inRule t then t:body else body
303         dirs'    = if isFileRef t &&
304                       inTree (frPath t) &&
305                       takeDirectory (frPath t) /= "."
306                    then S.insert (replaceFileName (frPath t) ".marker") dirs
307                    else dirs
308     in
309     CompiledRule outs' deps' predeps' body' dirs'
310     where
311         inTree :: FilePath -> Bool
312         inTree p =
313             case splitDirectories p of
314                 "..":_ -> False
315                 "/":_ -> False
316                 _ -> True
317
318 -- We wrap the AST of the parsed Hakefile to defind the 'find' and 'build'
319 -- primitives, and generate the correct expression type (HRule).  The result
320 -- is an unevaluted function [FilePath] -> HRule, that needs to be supplied
321 -- with the list of all files in the source directory.
322 wrapHake :: FilePath -> Exp -> Exp
323 wrapHake hakefile hake_exp =
324     Paren (
325     Lambda dummy_loc [PVar (Ident "sourceDB")] (
326     Let (BDecls
327         [FunBind [Match -- This is 'find'
328             dummy_loc
329             (Ident "find")
330             [PVar (Ident "fn"), PVar (Ident "arg")]
331             Nothing
332             (UnGuardedRhs
333                 (Paren (App (App (App (Var (UnQual (Ident "fn")))
334                                       (Var (UnQual (Ident "sourceDB"))))
335                                  (Lit (String hakefile)))
336                        (Var (UnQual (Ident "arg"))))))
337             (BDecls [])],
338
339         FunBind [Match
340             dummy_loc
341             (Ident "build") -- This is 'build'
342             [PVar (Ident "a")]
343             Nothing
344             (UnGuardedRhs
345                 (App (App (App (Paren (App (Var (UnQual (Ident "buildFunction")))
346                                            (Var (UnQual (Ident "a")))))
347                                (Var (UnQual (Ident "sourceDB"))))
348                           (Lit (String hakefile)))
349                      (Var (UnQual (Ident "a")))))
350             (BDecls [])]
351         ])
352         (Paren (App (Con (UnQual (Ident "Rules")))
353                     hake_exp))
354     ))
355     where
356         dummy_loc = SrcLoc { srcFilename = "<hake internal>",
357                                 srcLine = 0, srcColumn = 0 }
358
359 --
360 -- Makefile generation
361 --
362
363 -- The Makefile header, generated once.
364 makefilePreamble :: Handle -> Opts -> [String] -> IO ()
365 makefilePreamble h opts args = 
366     mapM_ (hPutStrLn h)
367           ([ "# This Makefile is generated by Hake.  Do not edit!",
368              "# ",
369              "# Hake was invoked with the following command line args:" ] ++
370            [ "#        " ++ a | a <- args ] ++
371            [ "# ",
372              "SRCDIR=" ++ opt_sourcedir opts,
373              "HAKE_ARCHS=" ++ intercalate " " Config.architectures,
374              "include ./symbolic_targets.mk" ])
375
376 -- There a several valid top-level build directores, apart from the
377 -- architecture-specific one.
378 arch_list :: S.Set String
379 arch_list = S.fromList (Config.architectures ++
380                         ["", "src", "hake", "root", "tools", "docs"])
381
382 -- A rule is included if it applies to only "special" and configured
383 -- architectures.
384 allowedArchs :: [String] -> Bool
385 allowedArchs = all (\a -> a `S.member` arch_list)
386
387 -- The section corresponding to a Hakefile.  These routines all collect
388 -- and directories they see.
389 makefileSection :: Handle -> Opts -> FilePath -> HRule -> IO (S.Set FilePath)
390 makefileSection h opts hakepath rule = do
391     hPutStrLn h $ "# From: " ++ hakepath ++ "\n"
392     makefileRule h rule
393
394 makefileRule :: Handle -> HRule -> IO (S.Set FilePath)
395 makefileRule h (Error s) = do
396     hPutStrLn h $ "$(error " ++ s ++ ")\n"
397     return S.empty
398 makefileRule h (Rules rules) = do
399     dir_lists <- mapM (makefileRule h) rules
400     return $! S.unions dir_lists
401 makefileRule h (Include token) = do
402     when (allowedArchs [frArch token]) $
403         mapM_ (hPutStrLn h) [
404             "ifeq ($(MAKECMDGOALS),clean)",
405             "else ifeq ($(MAKECMDGOALS),rehake)",
406             "else ifeq ($(MAKECMDGOALS),Makefile)",
407             "else",
408             "include " ++ (formatToken token),
409             "endif",
410             "" ]
411     return S.empty
412 makefileRule h (HakeTypes.Rule tokens) =
413     if allowedArchs (map frArch tokens)
414         then makefileRuleInner h tokens False
415         else return S.empty
416 makefileRule h (Phony name double_colon tokens) = do
417     hPutStrLn h $ ".PHONY: " ++ name
418     makefileRuleInner h (Target "build" name : tokens) double_colon
419
420 printTokens :: Handle -> S.Set RuleToken -> IO ()
421 printTokens h tokens =
422     S.foldr (\t m -> hPutStr h (formatToken t) >> m) (return ()) tokens
423
424 printDirs :: Handle -> S.Set FilePath -> IO ()
425 printDirs h dirs =
426     S.foldr (\d m -> hPutStr h (d ++ " ") >> m) (return ()) dirs
427
428 makefileRuleInner :: Handle -> [RuleToken] -> Bool -> IO (S.Set FilePath)
429 makefileRuleInner h tokens double_colon = do
430     if S.null (ruleOutputs compiledRule)
431     then do
432         hPutStr h "# hake: omitted rule with no output: "
433         doBody
434     else do
435         printTokens h $ ruleOutputs compiledRule
436         if double_colon then hPutStr h ":: " else hPutStr h ": "
437         printTokens h $ ruleDepends compiledRule
438         hPutStr h " | directories "
439         printTokens h $ rulePreDepends compiledRule
440         hPutStrLn h ""
441         doBody
442     where
443         compiledRule = compileRule tokens
444
445         doBody :: IO (S.Set FilePath)
446         doBody = do
447             when (ruleBody compiledRule /= []) $ do
448                 hPutStr h "\t"
449                 mapM_ (hPutStr h . formatToken) $ ruleBody compiledRule
450             hPutStrLn h "\n"
451             return $ ruleDirs compiledRule
452
453 --
454 -- Functions to resolve path names in rules. 
455 --
456 -- Absolute paths are interpreted relative to one of the three trees: source,
457 -- build or install.  Relative paths are interpreted relative to the directory
458 -- containing the Hakefile that referenced them, within one of the above tree.
459 -- Both build and install trees are divided by architecture, while the source
460 -- tree is not.  All paths are output relative to the build directory.
461 --
462 -- For example, if we are building for architecture 'x86_64', with build tree
463 -- '/home/user/barrelfish/build' and build tree '/home/user/barrelfish'
464 -- (relative path '../', and we are compiling a Hakefile at 'apps/init/Hakefile'
465 -- (relative path  '../apps/init/Hakefile'), we would resolve as follows:
466 --
467 --   In SourceTree "../apps/init" "x86_64" "main.c"
468 --      -> "../apps/init/main.c"
469 --   In BuildTree "../apps/init" "x86_64" "/include/generated.h"
470 --      -> "./x86_64/include/generated.h"
471 --   Out BuildTree "../apps/init" "root" "/doc/manual.pdf"
472 --      -> "./doc/manual.pdf"
473 --
474 -- Note that the 'root' architecture is special, and always refers to the root
475 -- of the relevant tree.
476
477 -- Recurse through the Hake AST
478 resolvePaths :: Opts -> FilePath -> HRule -> HRule
479 resolvePaths o hakepath (Rules hrules)
480     = Rules $ map (resolvePaths o hakepath) hrules
481 resolvePaths o hakepath (HakeTypes.Rule tokens)
482     = HakeTypes.Rule $ map (resolveTokenPath o hakepath) tokens
483 resolvePaths o hakepath (Include token)
484     = Include $ resolveTokenPath o hakepath token
485 resolvePaths o hakepath (Error s)
486     = Error s
487 resolvePaths o hakepath (Phony name dbl tokens)
488     = Phony name dbl $ map (resolveTokenPath o hakepath) tokens
489
490 -- Now resolve at the level of individual rule tokens.  At this level,
491 -- we need to take into account the tree (source, build, or install).
492 resolveTokenPath :: Opts -> FilePath -> RuleToken -> RuleToken
493 -- An input token specifies which tree it refers to.
494 resolveTokenPath o hakepath (In tree arch path) = 
495     (In tree arch (treePath o tree arch path hakepath))
496 -- An output token implicitly refers to the build tree.
497 resolveTokenPath o hakepath (Out arch path) = 
498     (Out arch (treePath o BuildTree arch path hakepath))
499 -- A dependency token specifies which tree it refers to.
500 resolveTokenPath o hakepath (Dep tree arch path) = 
501     (Dep tree arch (treePath o tree arch path hakepath))
502 -- A non-dependency token specifies which tree it refers to.
503 resolveTokenPath o hakepath (NoDep tree arch path) = 
504     (NoDep tree arch (treePath o tree arch path hakepath))
505 -- A pre-dependency token specifies which tree it refers to.
506 resolveTokenPath o hakepath (PreDep tree arch path) = 
507     (PreDep tree arch (treePath o tree arch path hakepath))
508 -- An target token implicitly refers to the build tree.
509 resolveTokenPath o hakepath (Target arch path) = 
510     (Target arch (treePath o BuildTree arch path hakepath))
511 -- Other tokens don't contain paths to resolve.
512 resolveTokenPath _ _ token = token
513
514 -- Now we get down to the nitty gritty.  We have, in order:
515 --   o:        The options in force
516 --   tree:     The tree (source, build, or install)
517 --   arch:     The architecture (e.g. armv7)
518 --   path:     The pathname we want to resolve
519 --   hakepath: The directory containing the Hakefile
520 -- If the tree is SrcTree or the architecture is "root", everything
521 -- is relative to the top-level directory for that tree.  Otherwise,
522 -- it's relative to the top-level directory plus the architecture.
523 treePath :: Opts -> TreeRef -> FilePath -> FilePath -> FilePath -> FilePath
524 -- The architecture 'root' is special.
525 treePath o SrcTree "root" path hakepath = 
526     relPath (opt_sourcedir o) path hakepath
527 treePath o BuildTree "root" path hakepath = 
528     relPath "." path hakepath
529 treePath o InstallTree "root" path hakepath = 
530     relPath (opt_installdir o) path hakepath
531 -- Source-tree paths don't get an architecture.
532 treePath o SrcTree arch path hakepath =
533     relPath (opt_sourcedir o) path hakepath
534 treePath o BuildTree arch path hakepath =
535     relPath ("." </> arch) path hakepath
536 treePath o InstallTree arch path hakepath =
537     relPath (opt_installdir o </> arch) path hakepath
538
539 -- First evaluate the given path 'path', relative to the Hakefile directory
540 -- 'hakepath'.  If 'path' is absolute (i.e. begins with a /), it is unchanged.
541 -- Otherwise it is appended to 'hakepath'.  We then treat this as a relative
542 -- path (by removing any initial /), and append it to the relevant tree root
543 -- (which may or may not have an architecture path appended already).
544 relPath treeroot path hakepath =
545     treeroot </> stripSlash (hakepath </> path)
546
547 -- Strip any leading slash from the filename.  This is much faster than
548 -- 'makeRelative "/"'.
549 stripSlash :: FilePath -> FilePath
550 stripSlash ('/':cs) = cs
551 stripSlash cs = cs
552
553 -- Emit the rule to rebuild the Hakefile.
554 makeHakeDeps :: Handle -> Opts -> [String] -> IO ()
555 makeHakeDeps h o l = do
556     makefileRule h rule
557     hPutStrLn h ".DELETE_ON_ERROR:\n" -- this applies to following targets.
558     where
559         hake = resolveTokenPath o "" (In InstallTree "root" "/hake/hake")
560         makefile = resolveTokenPath o "/" (Out "root" (opt_makefilename o))
561         rule = HakeTypes.Rule
562                     ( [ hake, 
563                         Str "--source-dir", Str (opt_sourcedir o),
564                         Str "--install-dir", Str (opt_installdir o),
565                         Str "--output-filename", makefile
566                       ] ++
567                       [ Dep SrcTree "root" h | h <- l ]
568                     )
569
570 -- Emit the rules to create the build directories
571 makeDirectories :: Handle -> S.Set FilePath -> IO ()
572 makeDirectories h dirs = do
573     hPutStrLn h "# Directories follow"
574     hPutStrLn h "DIRECTORIES=\\"
575     mapM_ (\d -> hPutStrLn h $ "    " ++ d ++ " \\") (S.toList dirs)
576     hPutStrLn h "\n"
577     hPutStrLn h ".PHONY: directories"
578     hPutStr h "directories: $(DIRECTORIES)"
579     hPutStrLn h ""
580     hPutStrLn h "%.marker:"
581     hPutStrLn h "\tmkdir -p `dirname $@`"
582     hPutStrLn h "\ttouch $@"
583
584 makeDir :: Handle -> FilePath -> IO ()
585 makeDir h dir = do
586     hPutStrLn h $ "hake_dirs: " ++ dir ++ "\n"
587     hPutStrLn h $ dir ++ ":"
588     hPutStrLn h $ "\tmkdir -p " ++ (takeDirectory dir)
589     hPutStrLn h $ "\ttouch " ++ dir
590     hPutStrLn h ""
591
592 --
593 -- The top level
594 --
595
596 body :: HakeMonad ()
597 body =  do
598     -- Parse arguments; architectures default to config file
599     args <- liftIO $ System.Environment.getArgs
600     let o1 = parse_arguments args
601         al = if opt_architectures o1 == [] 
602              then Config.architectures 
603              else opt_architectures o1
604         opts' = o1 { opt_architectures = al }
605
606     when (opt_usage_error opts') $
607         throwError (HakeError usage 1)
608
609     -- Check configuration settings.
610     -- This is currently known at compile time, but might not always be!
611     when (isJust configErrors) $
612         throwError (HakeError ("Error in configuration: " ++
613                                (fromJust configErrors)) 2)
614
615     -- Canonicalise directories
616     abs_sourcedir   <- liftIO $ canonicalizePath $ opt_sourcedir opts'
617     abs_bfsourcedir <- liftIO $ canonicalizePath $ opt_bfsourcedir opts'
618     abs_installdir  <- liftIO $ canonicalizePath $ opt_installdir opts'
619     let opts = opts' { opt_abs_sourcedir   = abs_sourcedir,
620                        opt_abs_bfsourcedir = abs_bfsourcedir,
621                        opt_abs_installdir  = abs_installdir }
622
623     liftIO $ putStrLn ("Source directory: " ++ opt_sourcedir opts ++
624                        " (" ++ opt_abs_sourcedir opts ++ ")")
625     liftIO $ putStrLn ("BF Source directory: " ++ opt_bfsourcedir opts ++
626                        " (" ++ opt_abs_bfsourcedir opts ++ ")")
627     liftIO $ putStrLn ("Install directory: " ++ opt_installdir opts ++
628                        " (" ++ opt_abs_installdir opts ++ ")")
629
630     -- Find Hakefiles
631     liftIO $ putStrLn "Scanning directory tree..."
632     (relfiles, hakefiles) <- liftIO $ listFiles (opt_sourcedir opts)
633     let srcDB = tdbBuild relfiles
634
635     -- Open the Makefile and write the preamble
636     liftIO $ putStrLn $ "Creating " ++ (opt_makefilename opts) ++ "..."
637     makefile <- liftIO $ openFile(opt_makefilename opts) WriteMode
638     liftIO $ makefilePreamble makefile opts args
639     liftIO $ makeHakeDeps makefile opts $ map fst hakefiles
640
641     -- Evaluate Hakefiles
642     liftIO $ putStrLn $ "Evaluating " ++ show (length hakefiles) ++
643                         " Hakefiles..."
644     dirs <- liftIO $ evalHakeFiles makefile opts srcDB hakefiles
645
646     -- Emit directory rules
647     liftIO $ putStrLn $ "Generating build directory dependencies..."
648     liftIO $ makeDirectories makefile dirs
649
650     liftIO $ hFlush makefile
651     liftIO $ hClose makefile
652     return ()
653
654 main :: IO () 
655 main = do
656     r <- runErrorT $ body `catchError` handleFailure
657     exitWith ExitSuccess
658     where
659         handleFailure (HakeError str n) = do
660             liftIO $ putStrLn str
661             liftIO $ exitWith (ExitFailure n)