a19c55c84d06ce46d993abad34466f8e6108e800
[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
129     | ignore (takeFileName root) = return ([], [])
130     | otherwise = do
131         isdir <- doesDirectoryExist root
132         if isdir then do
133             children <- getDirectoryContents root
134             walkchildren children
135         else do
136             hake <- maybeHake root
137             return ([root], hake)
138     where
139         -- Walk the child directories in parallel.  This speeds things up
140         -- dramatically over NFS, with its high latency.
141         walkchildren :: [FilePath] -> IO ([FilePath], [(FilePath, String)])
142         walkchildren children = do
143             children_async <- mapM (async.walkchild) children
144             results <- mapM wait children_async
145             return $ joinResults results
146
147         joinResults :: [([a],[b])] -> ([a],[b])
148         joinResults [] = ([],[])
149         joinResults ((as,bs):xs) =
150             let (as',bs') = joinResults xs in
151                 (as ++ as', bs ++ bs')
152
153         walkchild :: FilePath -> IO ([FilePath], [(FilePath, String)])
154         walkchild child = listFiles (root </> child)
155
156         -- Load Hakfiles eagerly.  This amounts to <1MB for Barrelfish (2015).
157         maybeHake path
158             | takeFileName path == "Hakefile" = do
159                 contents <- readFile path
160                 return [(path, contents)]
161             | otherwise = return []
162
163         -- Don't descend into revision-control or build directories.
164         ignore :: FilePath -> Bool
165         ignore "."          = True
166         ignore ".."         = True
167         ignore "CMakeFiles" = True
168         ignore ".hg"        = True
169         ignore ".git"       = True
170         ignore "build"      = True
171         ignore _            = False
172
173 --
174 -- Hake parsing using the GHC API
175 --
176
177 -- We invoke GHC to parse the Hakefiles in a preconfigured environment,
178 -- to implement the Hake DSL.
179 evalHakeFiles :: Handle -> Opts -> TreeDB -> [(FilePath, String)] ->
180                  IO (S.Set FilePath)
181 evalHakeFiles makefile o srcDB hakefiles =
182     defaultErrorHandler defaultFatalMessager defaultFlushOut $
183         runGhc (Just libdir) $
184         driveGhc makefile o srcDB hakefiles
185
186 -- This is the code that executes in the GHC monad.
187 driveGhc :: Handle -> Opts -> TreeDB -> [(FilePath, String)] ->
188             Ghc (S.Set FilePath)
189 driveGhc makefile o srcDB hakefiles = do
190     -- Set the RTS flags
191     dflags <- getSessionDynFlags
192     let dflags' = foldl xopt_set dflags [ Opt_DeriveDataTypeable,
193                                           Opt_StandaloneDeriving ]
194     _ <- setSessionDynFlags dflags'{
195         importPaths = module_paths,
196         hiDir = Just "./hake",
197         objectDir = Just "./hake"
198     }
199
200     -- Set compilation targets i.e. everything that needs to be built from
201     -- source (*.hs).
202     targets <- mapM (\m -> guessTarget m Nothing) source_modules
203     setTargets targets
204     load LoadAllTargets
205
206     -- Import both system and Hake modules.
207     setContext
208         ([IIDecl $ simpleImportDecl $ mkModuleName m |
209             m <- modules] ++
210          [IIDecl $ (simpleImportDecl $ mkModuleName m) {
211                 ideclQualified = True
212           } | m <- qualified_modules])
213
214     -- Emit Makefile sections corresponding to Hakefiles
215     buildSections hakefiles
216
217     where
218         module_paths = [ (opt_installdir o) </> "hake", ".", 
219                          (opt_bfsourcedir o) </> "hake" ]
220         source_modules = [ "HakeTypes", "RuleDefs", "Args", "Config",
221                            "TreeDB" ]
222         modules = [ "Prelude", "System.FilePath", "HakeTypes", "RuleDefs",
223                     "Args", "TreeDB"  ]
224         qualified_modules = [ "Config", "Data.List" ]
225
226         -- Evaluate one Hakefile, and emit its Makefile section.  We collect
227         -- referenced directories as we go, to generate the 'directories'
228         -- rules later.
229         buildSections' :: (S.Set FilePath) -> [(FilePath, String)] ->
230                           Ghc (S.Set FilePath)
231         buildSections' dirs [] = return dirs
232         buildSections' dirs ((abs_hakepath, contents):hs) = do
233             let hakepath = makeRelative (opt_sourcedir o) abs_hakepath
234             rule <- evaluate hakepath contents
235             dirs' <- liftIO $ makefileSection makefile o hakepath rule
236             buildSections' (S.union dirs' dirs) hs
237
238         buildSections :: [(FilePath, String)] -> Ghc (S.Set FilePath)
239         buildSections hs = buildSections' S.empty hs
240
241         -- Evaluate a Hakefile, returning something of the form
242         -- Rule [...]
243         evaluate :: FilePath -> String -> Ghc HRule
244         evaluate hakepath hake_raw = do
245             case hake_parse of
246                 Left hake_expr -> do
247                     let hake_wrapped =
248                             prettyPrintWithMode (defaultMode {layout = PPNoLayout}) $
249                                 wrapHake hakepath hake_expr
250
251                     -- Evaluate in GHC
252                     val <- dynCompileExpr $ hake_wrapped ++
253                                             " :: TreeDB -> HRule"
254                     let rule = fromDyn val (\_ -> Error "failed")
255
256                     -- Path resolution
257                     let resolved_rule =
258                             resolvePaths o (takeDirectory hakepath)
259                                            (rule srcDB)
260                     return resolved_rule
261                 Right hake_error -> do
262                     return $ Error "failed"
263             where
264                 hake_parse = parseHake hakepath hake_raw
265
266 -- Parse a Hakefile, prior to wrapping it with Hake definitions
267 parseHake :: FilePath -> String -> Either Exp HakeError
268 parseHake filename contents =
269     case result of
270         ParseOk e -> Left e
271         ParseFailed loc str ->
272             Right $ HakeError (show loc ++ ": " ++ str) 2
273     where
274         result =
275             parseExpWithMode
276                 (defaultParseMode {
277                     parseFilename = filename,
278                     baseLanguage = Haskell2010 })
279                 contents
280
281 -- Split a Hake rule up by token type.  It's more efficient to do this
282 -- in a single pass, than to filter each as it's required.
283 data CompiledRule =
284     CompiledRule {
285         ruleOutputs    :: S.Set RuleToken,
286         ruleDepends    :: S.Set RuleToken,
287         rulePreDepends :: S.Set RuleToken,
288         ruleBody       :: [RuleToken],
289         ruleDirs       :: S.Set FilePath
290     }
291
292 compileRule :: [RuleToken] -> CompiledRule
293 compileRule [] = CompiledRule S.empty  S.empty  S.empty  []  S.empty
294 compileRule (t:ts) =
295     let CompiledRule outs deps predeps body dirs = compileRule ts
296         outs'    = if isOutput t then S.insert t outs else outs
297         deps'    = if isDependency t then S.insert t deps else deps
298         predeps' = if isPredependency t then S.insert t predeps else predeps
299         body'    = if inRule t then t:body else body
300         dirs'    = if isFileRef t &&
301                       inTree (frPath t) &&
302                       takeDirectory (frPath t) /= "."
303                    then S.insert (replaceFileName (frPath t) ".marker") dirs
304                    else dirs
305     in
306     CompiledRule outs' deps' predeps' body' dirs'
307     where
308         inTree :: FilePath -> Bool
309         inTree p =
310             case splitDirectories p of
311                 "..":_ -> False
312                 "/":_ -> False
313                 _ -> True
314
315 -- We wrap the AST of the parsed Hakefile to defind the 'find' and 'build'
316 -- primitives, and generate the correct expression type (HRule).  The result
317 -- is an unevaluted function [FilePath] -> HRule, that needs to be supplied
318 -- with the list of all files in the source directory.
319 wrapHake :: FilePath -> Exp -> Exp
320 wrapHake hakefile hake_exp =
321     Paren (
322     Lambda dummy_loc [PVar (Ident "sourceDB")] (
323     Let (BDecls
324         [FunBind [Match -- This is 'find'
325             dummy_loc
326             (Ident "find")
327             [PVar (Ident "fn"), PVar (Ident "arg")]
328             Nothing
329             (UnGuardedRhs
330                 (Paren (App (App (App (Var (UnQual (Ident "fn")))
331                                       (Var (UnQual (Ident "sourceDB"))))
332                                  (Lit (String hakefile)))
333                        (Var (UnQual (Ident "arg"))))))
334             (BDecls [])],
335
336         FunBind [Match
337             dummy_loc
338             (Ident "build") -- This is 'build'
339             [PVar (Ident "a")]
340             Nothing
341             (UnGuardedRhs
342                 (App (App (App (Paren (App (Var (UnQual (Ident "buildFunction")))
343                                            (Var (UnQual (Ident "a")))))
344                                (Var (UnQual (Ident "sourceDB"))))
345                           (Lit (String hakefile)))
346                      (Var (UnQual (Ident "a")))))
347             (BDecls [])]
348         ])
349         (Paren (App (Con (UnQual (Ident "Rules")))
350                     hake_exp))
351     ))
352     where
353         dummy_loc = SrcLoc { srcFilename = "<hake internal>",
354                                 srcLine = 0, srcColumn = 0 }
355
356 --
357 -- Makefile generation
358 --
359
360 -- The Makefile header, generated once.
361 makefilePreamble :: Handle -> Opts -> [String] -> IO ()
362 makefilePreamble h opts args = 
363     mapM_ (hPutStrLn h)
364           ([ "# This Makefile is generated by Hake.  Do not edit!",
365              "# ",
366              "# Hake was invoked with the following command line args:" ] ++
367            [ "#        " ++ a | a <- args ] ++
368            [ "# ",
369              "SRCDIR=" ++ (opt_sourcedir opts),
370              "HAKE_ARCHS=" ++ (concat $ intersperse " " Config.architectures),
371              "include ./symbolic_targets.mk" ])
372
373 -- There a several valid top-level build directores, apart from the
374 -- architecture-specific one.
375 arch_list :: S.Set String
376 arch_list = S.fromList (Config.architectures ++
377                         ["", "src", "hake", "root", "tools", "docs"])
378
379 -- A rule is included if it applies to only "special" and configured
380 -- architectures.
381 allowedArchs :: [String] -> Bool
382 allowedArchs = all (\a -> a `S.member` arch_list)
383
384 -- The section corresponding to a Hakefile.  These routines all collect
385 -- and directories they see.
386 makefileSection :: Handle -> Opts -> FilePath -> HRule -> IO (S.Set FilePath)
387 makefileSection h opts hakepath rule = do
388     hPutStrLn h $ "# From: " ++ hakepath ++ "\n"
389     makefileRule h rule
390
391 makefileRule :: Handle -> HRule -> IO (S.Set FilePath)
392 makefileRule h (Error s) = do
393     hPutStrLn h $ "$(error " ++ s ++ ")\n"
394     return S.empty
395 makefileRule h (Rules rules) = do
396     dir_lists <- mapM (makefileRule h) rules
397     return $! S.unions dir_lists
398 makefileRule h (Include token) = do
399     when (allowedArchs [frArch token]) $
400         mapM_ (hPutStrLn h) [
401             "ifeq ($(MAKECMDGOALS),clean)",
402             "else ifeq ($(MAKECMDGOALS),rehake)",
403             "else ifeq ($(MAKECMDGOALS),Makefile)",
404             "else",
405             "include " ++ (formatToken token),
406             "endif",
407             "" ]
408     return S.empty
409 makefileRule h (HakeTypes.Rule tokens) =
410     if allowedArchs (map frArch tokens)
411         then makefileRuleInner h tokens False
412         else return S.empty
413 makefileRule h (Phony name double_colon tokens) = do
414     hPutStrLn h $ ".PHONY: " ++ name
415     makefileRuleInner h (Target "build" name : tokens) double_colon
416
417 printTokens :: Handle -> S.Set RuleToken -> IO ()
418 printTokens h tokens =
419     S.foldr (\t m -> hPutStr h (formatToken t) >> m) (return ()) tokens
420
421 printDirs :: Handle -> S.Set FilePath -> IO ()
422 printDirs h dirs =
423     S.foldr (\d m -> hPutStr h (d ++ " ") >> m) (return ()) dirs
424
425 makefileRuleInner :: Handle -> [RuleToken] -> Bool -> IO (S.Set FilePath)
426 makefileRuleInner h tokens double_colon = do
427     if S.null (ruleOutputs compiledRule)
428     then do
429         hPutStr h "# hake: omitted rule with no output: "
430         doBody
431     else do
432         printTokens h $ ruleOutputs compiledRule
433         if double_colon then hPutStr h ":: " else hPutStr h ": "
434         printTokens h $ ruleDepends compiledRule
435         -- printDirs h $ ruleDirs compiledRule
436         hPutStr h " | directories "
437         --when (not (S.null (rulePreDepends compiledRule))) $ do
438         printTokens h $ rulePreDepends compiledRule
439         hPutStrLn h ""
440         doBody
441     where
442         compiledRule = compileRule tokens
443
444         doBody :: IO (S.Set FilePath)
445         doBody = do
446             when (ruleBody compiledRule /= []) $ do
447                 hPutStr h "\t"
448                 mapM_ (hPutStr h . formatToken) $ ruleBody compiledRule
449             hPutStrLn h "\n"
450             return $ ruleDirs compiledRule
451
452 --
453 -- Functions to resolve path names in rules. 
454 --
455 -- Absolute paths are interpreted relative to one of the three trees: source,
456 -- build or install.  Relative paths are interpreted relative to the directory
457 -- containing the Hakefile that referenced them, within one of the above tree.
458 -- Both build and install trees are divided by architecture, while the source
459 -- tree is not.  All paths are output relative to the build directory.
460 --
461 -- For example, if we are building for architecture 'x86_64', with build tree
462 -- '/home/user/barrelfish/build' and build tree '/home/user/barrelfish'
463 -- (relative path '../', and we are compiling a Hakefile at 'apps/init/Hakefile'
464 -- (relative path  '../apps/init/Hakefile'), we would resolve as follows:
465 --
466 --   In SourceTree "../apps/init" "x86_64" "main.c"
467 --      -> "../apps/init/main.c"
468 --   In BuildTree "../apps/init" "x86_64" "/include/generated.h"
469 --      -> "./x86_64/include/generated.h"
470 --   Out BuildTree "../apps/init" "root" "/doc/manual.pdf"
471 --      -> "./doc/manual.pdf"
472 --
473 -- Note that the 'root' architecture is special, and always refers to the root
474 -- of the relevant tree.
475
476 -- Recurse through the Hake AST
477 resolvePaths :: Opts -> FilePath -> HRule -> HRule
478 resolvePaths o hakepath (Rules hrules)
479     = Rules $ map (resolvePaths o hakepath) hrules
480 resolvePaths o hakepath (HakeTypes.Rule tokens)
481     = HakeTypes.Rule $ map (resolveTokenPath o hakepath) tokens
482 resolvePaths o hakepath (Include token)
483     = Include $ resolveTokenPath o hakepath token
484 resolvePaths o hakepath (Error s)
485     = Error s
486 resolvePaths o hakepath (Phony name dbl tokens)
487     = Phony name dbl $ map (resolveTokenPath o hakepath) tokens
488
489 -- Now resolve at the level of individual rule tokens.  At this level,
490 -- we need to take into account the tree (source, build, or install).
491 resolveTokenPath :: Opts -> FilePath -> RuleToken -> RuleToken
492 -- An input token specifies which tree it refers to.
493 resolveTokenPath o hakepath (In tree arch path) = 
494     (In tree arch (treePath o tree arch path hakepath))
495 -- An output token implicitly refers to the build tree.
496 resolveTokenPath o hakepath (Out arch path) = 
497     (Out arch (treePath o BuildTree arch path hakepath))
498 -- A dependency token specifies which tree it refers to.
499 resolveTokenPath o hakepath (Dep tree arch path) = 
500     (Dep tree arch (treePath o tree arch path hakepath))
501 -- A non-dependency token specifies which tree it refers to.
502 resolveTokenPath o hakepath (NoDep tree arch path) = 
503     (NoDep tree arch (treePath o tree arch path hakepath))
504 -- A pre-dependency token specifies which tree it refers to.
505 resolveTokenPath o hakepath (PreDep tree arch path) = 
506     (PreDep tree arch (treePath o tree arch path hakepath))
507 -- An target token implicitly refers to the build tree.
508 resolveTokenPath o hakepath (Target arch path) = 
509     (Target arch (treePath o BuildTree arch path hakepath))
510 -- Other tokens don't contain paths to resolve.
511 resolveTokenPath _ _ token = token
512
513 -- Now we get down to the nitty gritty.  We have, in order:
514 --   o:        The options in force
515 --   tree:     The tree (source, build, or install)
516 --   arch:     The architecture (e.g. armv7)
517 --   path:     The pathname we want to resolve
518 --   hakepath: The directory containing the Hakefile
519 -- If the tree is SrcTree or the architecture is "root", everything
520 -- is relative to the top-level directory for that tree.  Otherwise,
521 -- it's relative to the top-level directory plus the architecture.
522 treePath :: Opts -> TreeRef -> FilePath -> FilePath -> FilePath -> FilePath
523 -- The architecture 'root' is special.
524 treePath o SrcTree "root" path hakepath = 
525     relPath (opt_sourcedir o) path hakepath
526 treePath o BuildTree "root" path hakepath = 
527     relPath "." path hakepath
528 treePath o InstallTree "root" path hakepath = 
529     relPath (opt_installdir o) path hakepath
530 -- Source-tree paths don't get an architecture.
531 treePath o SrcTree arch path hakepath =
532     relPath (opt_sourcedir o) path hakepath
533 treePath o BuildTree arch path hakepath =
534     relPath ("." </> arch) path hakepath
535 treePath o InstallTree arch path hakepath =
536     relPath (opt_installdir o </> arch) path hakepath
537
538 -- First evaluate the given path 'path', relative to the Hakefile directory
539 -- 'hakepath'.  If 'path' is absolute (i.e. begins with a /), it is unchanged.
540 -- Otherwise it is appended to 'hakepath'.  We then treat this as a relative
541 -- path (by removing any initial /), and append it to the relevant tree root
542 -- (which may or may not have an architecture path appended already).
543 relPath treeroot path hakepath =
544     treeroot </> stripSlash (hakepath </> path)
545
546 -- Strip any leading slash from the filename.  This is much faster than
547 -- 'makeRelative "/"'.
548 stripSlash :: FilePath -> FilePath
549 stripSlash ('/':cs) = cs
550 stripSlash cs = cs
551
552 -- Emit the rule to rebuild the Hakefile.
553 makeHakeDeps :: Handle -> Opts -> [String] -> IO ()
554 makeHakeDeps h o l = do
555     makefileRule h rule
556     hPutStrLn h ".DELETE_ON_ERROR:\n" -- this applies to following targets.
557     where
558         hake = resolveTokenPath o "" (In InstallTree "root" "/hake/hake")
559         makefile = resolveTokenPath o "/" (Out "root" (opt_makefilename o))
560         rule = HakeTypes.Rule
561                     ( [ hake, 
562                         Str "--source-dir", Str (opt_sourcedir o),
563                         Str "--install-dir", Str (opt_installdir o),
564                         Str "--output-filename", makefile
565                       ] ++
566                       [ Dep SrcTree "root" h | h <- l ]
567                     )
568
569 -- Emit the rules to create the build directories
570 makeDirectories :: Handle -> S.Set FilePath -> IO ()
571 makeDirectories h dirs = do
572     hPutStrLn h "# Directories follow"
573     --mapM_ (makeDir h) (S.toList (S.delete ("." </> ".marker") dirs))
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 "Reading directory tree..."
632     (allfiles, hakefiles) <- liftIO $ listFiles (opt_sourcedir opts)
633     let relfiles = map (makeRelative $ opt_sourcedir opts') allfiles
634     let srcDB = tdbBuild relfiles
635
636     -- Open the Makefile and write the preamble
637     liftIO $ putStrLn $ "Opening " ++ (opt_makefilename opts)
638     makefile <- liftIO $ openFile(opt_makefilename opts) WriteMode
639     liftIO $ makefilePreamble makefile opts args
640     liftIO $ makeHakeDeps makefile opts $ map fst hakefiles
641
642     -- Evaluate Hakefiles
643     liftIO $ putStrLn $ "Evaluating " ++ show (length hakefiles) ++
644                         " Hakefiles..."
645     dirs <- liftIO $ evalHakeFiles makefile opts srcDB hakefiles
646
647     -- Emit directory rules
648     liftIO $ putStrLn $ "Generating build directory dependencies..."
649     liftIO $ makeDirectories makefile dirs
650
651     liftIO $ hFlush makefile
652     liftIO $ hClose makefile
653     return ()
654
655 main :: IO () 
656 main = do
657     r <- runErrorT $ body `catchError` handleFailure
658     exitWith ExitSuccess
659     where
660         handleFailure (HakeError str n) = do
661             liftIO $ putStrLn str
662             liftIO $ exitWith (ExitFailure n)