git.barrelfish.org Git - barrelfish/blob - 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)