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