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=" ++ (concat $ intersperse " " 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         -- printDirs h $ ruleDirs compiledRule
 439         hPutStr h " | directories "
 440         --when (not (S.null (rulePreDepends compiledRule))) $ do
 441         printTokens h $ rulePreDepends compiledRule
 442         hPutStrLn h ""
 443         doBody
 444     where
 445         compiledRule = compileRule tokens
 446
 447         doBody :: IO (S.Set FilePath)
 448         doBody = do
 449             when (ruleBody compiledRule /= []) $ do
 450                 hPutStr h "\t"
 451                 mapM_ (hPutStr h . formatToken) $ ruleBody compiledRule
 452             hPutStrLn h "\n"
 453             return $ ruleDirs compiledRule
 454
 455 --
 456 -- Functions to resolve path names in rules.
 457 --
 458 -- Absolute paths are interpreted relative to one of the three trees: source,
 459 -- build or install.  Relative paths are interpreted relative to the directory
 460 -- containing the Hakefile that referenced them, within one of the above tree.
 461 -- Both build and install trees are divided by architecture, while the source
 462 -- tree is not.  All paths are output relative to the build directory.
 463 --
 464 -- For example, if we are building for architecture 'x86_64', with build tree
 465 -- '/home/user/barrelfish/build' and build tree '/home/user/barrelfish'
 466 -- (relative path '../', and we are compiling a Hakefile at 'apps/init/Hakefile'
 467 -- (relative path  '../apps/init/Hakefile'), we would resolve as follows:
 468 --
 469 --   In SourceTree "../apps/init" "x86_64" "main.c"
 470 --      -> "../apps/init/main.c"
 471 --   In BuildTree "../apps/init" "x86_64" "/include/generated.h"
 472 --      -> "./x86_64/include/generated.h"
 473 --   Out BuildTree "../apps/init" "root" "/doc/manual.pdf"
 474 --      -> "./doc/manual.pdf"
 475 --
 476 -- Note that the 'root' architecture is special, and always refers to the root
 477 -- of the relevant tree.
 478
 479 -- Recurse through the Hake AST
 480 resolvePaths :: Opts -> FilePath -> HRule -> HRule
 481 resolvePaths o hakepath (Rules hrules)
 482     = Rules $ map (resolvePaths o hakepath) hrules
 483 resolvePaths o hakepath (HakeTypes.Rule tokens)
 484     = HakeTypes.Rule $ map (resolveTokenPath o hakepath) tokens
 485 resolvePaths o hakepath (Include token)
 486     = Include $ resolveTokenPath o hakepath token
 487 resolvePaths o hakepath (Error s)
 488     = Error s
 489 resolvePaths o hakepath (Phony name dbl tokens)
 490     = Phony name dbl $ map (resolveTokenPath o hakepath) tokens
 491
 492 -- Now resolve at the level of individual rule tokens.  At this level,
 493 -- we need to take into account the tree (source, build, or install).
 494 resolveTokenPath :: Opts -> FilePath -> RuleToken -> RuleToken
 495 -- An input token specifies which tree it refers to.
 496 resolveTokenPath o hakepath (In tree arch path) =
 497     (In tree arch (treePath o tree arch path hakepath))
 498 -- An output token implicitly refers to the build tree.
 499 resolveTokenPath o hakepath (Out arch path) =
 500     (Out arch (treePath o BuildTree arch path hakepath))
 501 -- A dependency token specifies which tree it refers to.
 502 resolveTokenPath o hakepath (Dep tree arch path) =
 503     (Dep tree arch (treePath o tree arch path hakepath))
 504 -- A non-dependency token specifies which tree it refers to.
 505 resolveTokenPath o hakepath (NoDep tree arch path) =
 506     (NoDep tree arch (treePath o tree arch path hakepath))
 507 -- A pre-dependency token specifies which tree it refers to.
 508 resolveTokenPath o hakepath (PreDep tree arch path) =
 509     (PreDep tree arch (treePath o tree arch path hakepath))
 510 -- An target token implicitly refers to the build tree.
 511 resolveTokenPath o hakepath (Target arch path) =
 512     (Target arch (treePath o BuildTree arch path hakepath))
 513 -- Other tokens don't contain paths to resolve.
 514 resolveTokenPath _ _ token = token
 515
 516 -- Now we get down to the nitty gritty.  We have, in order:
 517 --   o:        The options in force
 518 --   tree:     The tree (source, build, or install)
 519 --   arch:     The architecture (e.g. armv7)
 520 --   path:     The pathname we want to resolve
 521 --   hakepath: The directory containing the Hakefile
 522 -- If the tree is SrcTree or the architecture is "root", everything
 523 -- is relative to the top-level directory for that tree.  Otherwise,
 524 -- it's relative to the top-level directory plus the architecture.
 525 treePath :: Opts -> TreeRef -> FilePath -> FilePath -> FilePath -> FilePath
 526 -- The architecture 'root' is special.
 527 treePath o SrcTree "root" path hakepath =
 528     relPath (opt_sourcedir o) path hakepath
 529 treePath o BuildTree "root" path hakepath =
 530     relPath "." path hakepath
 531 treePath o InstallTree "root" path hakepath =
 532     relPath (opt_installdir o) path hakepath
 533 -- Source-tree paths don't get an architecture.
 534 treePath o SrcTree arch path hakepath =
 535     relPath (opt_sourcedir o) path hakepath
 536 treePath o BuildTree arch path hakepath =
 537     relPath ("." </> arch) path hakepath
 538 treePath o InstallTree arch path hakepath =
 539     relPath (opt_installdir o </> arch) path hakepath
 540
 541 -- First evaluate the given path 'path', relative to the Hakefile directory
 542 -- 'hakepath'.  If 'path' is absolute (i.e. begins with a /), it is unchanged.
 543 -- Otherwise it is appended to 'hakepath'.  We then treat this as a relative
 544 -- path (by removing any initial /), and append it to the relevant tree root
 545 -- (which may or may not have an architecture path appended already).
 546 relPath treeroot path hakepath =
 547     treeroot </> stripSlash (hakepath </> path)
 548
 549 -- Strip any leading slash from the filename.  This is much faster than
 550 -- 'makeRelative "/"'.
 551 stripSlash :: FilePath -> FilePath
 552 stripSlash ('/':cs) = cs
 553 stripSlash cs = cs
 554
 555 -- Emit the rule to rebuild the Hakefile.
 556 makeHakeDeps :: Handle -> Opts -> [String] -> IO ()
 557 makeHakeDeps h o l = do
 558     makefileRule h rule
 559     hPutStrLn h ".DELETE_ON_ERROR:\n" -- this applies to following targets.
 560     where
 561         hake = resolveTokenPath o "" (In InstallTree "root" "/hake/hake")
 562         makefile = resolveTokenPath o "/" (Out "root" (opt_makefilename o))
 563         rule = HakeTypes.Rule
 564                     ( [ hake,
 565                         Str "--source-dir", Str (opt_sourcedir o),
 566                         Str "--install-dir", Str (opt_installdir o),
 567                         Str "--output-filename", makefile
 568                       ] ++
 569                       [ Dep SrcTree "root" h | h <- l ]
 570                     )
 571
 572 -- Emit the rules to create the build directories
 573 makeDirectories :: Handle -> S.Set FilePath -> IO ()
 574 makeDirectories h dirs = do
 575     hPutStrLn h "# Directories follow"
 576     --mapM_ (makeDir h) (S.toList (S.delete ("." </> ".marker") dirs))
 577     hPutStrLn h "DIRECTORIES=\\"
 578     mapM_ (\d -> hPutStrLn h $ "    " ++ d ++ " \\") (S.toList dirs)
 579     hPutStrLn h "\n"
 580     hPutStrLn h ".PHONY: directories"
 581     hPutStr h "directories: $(DIRECTORIES)"
 582     hPutStrLn h ""
 583     hPutStrLn h "%.marker:"
 584     hPutStrLn h "\tmkdir -p `dirname $@`"
 585     hPutStrLn h "\ttouch $@"
 586
 587 makeDir :: Handle -> FilePath -> IO ()
 588 makeDir h dir = do
 589     hPutStrLn h $ "hake_dirs: " ++ dir ++ "\n"
 590     hPutStrLn h $ dir ++ ":"
 591     hPutStrLn h $ "\tmkdir -p " ++ (takeDirectory dir)
 592     hPutStrLn h $ "\ttouch " ++ dir
 593     hPutStrLn h ""
 594
 595 --
 596 -- The top level
 597 --
 598
 599 body :: HakeMonad ()
 600 body =  do
 601     -- Parse arguments; architectures default to config file
 602     args <- liftIO $ System.Environment.getArgs
 603     let o1 = parse_arguments args
 604         al = if opt_architectures o1 == []
 605              then Config.architectures
 606              else opt_architectures o1
 607         opts' = o1 { opt_architectures = al }
 608
 609     when (opt_usage_error opts') $
 610         throwError (HakeError usage 1)
 611
 612     -- Check configuration settings.
 613     -- This is currently known at compile time, but might not always be!
 614     when (isJust configErrors) $
 615         throwError (HakeError ("Error in configuration: " ++
 616                                (fromJust configErrors)) 2)
 617
 618     -- Canonicalise directories
 619     abs_sourcedir   <- liftIO $ canonicalizePath $ opt_sourcedir opts'
 620     abs_bfsourcedir <- liftIO $ canonicalizePath $ opt_bfsourcedir opts'
 621     abs_installdir  <- liftIO $ canonicalizePath $ opt_installdir opts'
 622     let opts = opts' { opt_abs_sourcedir   = abs_sourcedir,
 623                        opt_abs_bfsourcedir = abs_bfsourcedir,
 624                        opt_abs_installdir  = abs_installdir }
 625
 626     liftIO $ putStrLn ("Source directory: " ++ opt_sourcedir opts ++
 627                        " (" ++ opt_abs_sourcedir opts ++ ")")
 628     liftIO $ putStrLn ("BF Source directory: " ++ opt_bfsourcedir opts ++
 629                        " (" ++ opt_abs_bfsourcedir opts ++ ")")
 630     liftIO $ putStrLn ("Install directory: " ++ opt_installdir opts ++
 631                        " (" ++ opt_abs_installdir opts ++ ")")
 632
 633     -- Find Hakefiles
 634     liftIO $ putStrLn "Reading directory tree..."
 635     (relfiles, hakefiles) <- liftIO $ listFiles (opt_sourcedir opts)
 636     let srcDB = tdbBuild relfiles
 637
 638     -- Open the Makefile and write the preamble
 639     liftIO $ putStrLn $ "Opening " ++ (opt_makefilename opts)
 640     makefile <- liftIO $ openFile(opt_makefilename opts) WriteMode
 641     liftIO $ makefilePreamble makefile opts args
 642     liftIO $ makeHakeDeps makefile opts $ map fst hakefiles
 643
 644     -- Evaluate Hakefiles
 645     liftIO $ putStrLn $ "Evaluating " ++ show (length hakefiles) ++
 646                         " Hakefiles..."
 647     dirs <- liftIO $ evalHakeFiles makefile opts srcDB hakefiles
 648
 649     -- Emit directory rules
 650     liftIO $ putStrLn $ "Generating build directory dependencies..."
 651     liftIO $ makeDirectories makefile dirs
 652
 653     liftIO $ hFlush makefile
 654     liftIO $ hClose makefile
 655     return ()
 656
 657 main :: IO ()
 658 main = do
 659     r <- runErrorT $ body `catchError` handleFailure
 660     exitWith ExitSuccess
 661     where
 662         handleFailure (HakeError str n) = do
 663             liftIO $ putStrLn str
 664             liftIO $ exitWith (ExitFailure n)