1 import Control.Monad.Error
6 import qualified Data.Set as S
8 import System.Directory
9 import System.Environment
11 import System.FilePath
15 import GHC hiding (Target, Ghc, GhcT, runGhc, runGhcT, FunBind, Match)
16 import GHC.Paths (libdir)
17 import Control.Monad.Ghc
18 import DynFlags (defaultFatalMessager, defaultFlushOut,
19 xopt_set, ExtensionFlag (Opt_DeriveDataTypeable))
22 import Language.Haskell.Exts
27 import qualified Config
30 data HakeError = HakeError String Int
31 instance Error HakeError
32 type HakeMonad = ErrorT HakeError IO
35 -- Command line options and parsing code
37 data Opts = Opts { opt_makefilename :: String,
38 opt_installdir :: String,
39 opt_sourcedir :: String,
40 opt_bfsourcedir :: String,
41 opt_usage_error :: Bool,
42 opt_architectures :: [String],
43 opt_verbosity :: Integer
47 parse_arguments :: [String] -> Opts
49 Opts { opt_makefilename = "Makefile",
50 opt_installdir = Config.install_dir,
51 opt_sourcedir = Config.source_dir,
52 opt_bfsourcedir = Config.source_dir,
53 opt_usage_error = False,
54 opt_architectures = [],
56 parse_arguments ("--install-dir" : (s : t)) =
57 (parse_arguments t) { opt_installdir = s }
58 parse_arguments ("--source-dir" : s : t) =
59 (parse_arguments t) { opt_sourcedir = s }
60 parse_arguments ("--bfsource-dir" : s : t) =
61 (parse_arguments t) { opt_bfsourcedir = s }
62 parse_arguments ("--output-filename" : s : t) =
63 (parse_arguments t) { opt_makefilename = s }
64 parse_arguments ("--quiet" : t ) =
65 (parse_arguments t) { opt_verbosity = 0 }
66 parse_arguments ("--verbose" : t ) =
67 (parse_arguments t) { opt_verbosity = 2 }
68 parse_arguments ("--architecture" : a : t ) =
70 o2 = parse_arguments t
71 arches = (a : opt_architectures o2)
73 o2 { opt_architectures = arches }
75 (parse_arguments []) { opt_usage_error = True }
78 usage = unlines [ "Usage: hake <options>",
79 " --source-dir <dir> (required)",
80 " --bfsource-dir <dir> (defaults to source dir)",
81 " --install-dir <dir> (defaults to source dir)",
86 -- check the configuration options, returning an error string if they're insane
87 configErrors :: Maybe String
89 | unknownArchs /= [] =
90 Just ("unknown architecture(s) specified: " ++
91 (concat $ intersperse ", " unknownArchs))
92 | Config.architectures == [] =
93 Just "no architectures defined"
94 | Config.lazy_thc && not Config.use_fp =
95 Just "Config.use_fp must be true to use Config.lazy_thc."
99 unknownArchs = Config.architectures \\ Args.allArchitectures
102 -- Walk all over a directory tree and build a complete list of pathnames
104 listFiles :: FilePath -> IO ([FilePath], [(FilePath, String)])
106 isdir <- doesDirectoryExist root
108 children <- getDirectoryContents root
109 walkchildren children
113 walkchildren :: [FilePath] -> IO ([FilePath], [(FilePath, String)])
114 walkchildren [] = return ([], [])
115 walkchildren (child:siblings) = do
116 (allfiles, hakefiles) <- walkchild child
117 (allfilesS, hakefilesS) <- walkchildren siblings
118 return $ (allfiles ++ allfilesS, hakefiles ++ hakefilesS)
120 walkchild :: FilePath -> IO ([FilePath], [(FilePath, String)])
125 (allfiles, hakefiles) <- listFiles (root </> child)
126 hake <- maybeHake child
127 return $ ((root </> child) : allfiles,
130 maybeHake "Hakefile" = do
131 contents <- readFile (root </> child)
132 return [(root </> child, contents)]
133 maybeHake _ = return []
135 ignore :: FilePath -> Bool
138 ignore "CMakeFiles" = True
140 ignore "build" = True
144 instance Show SuccessFlag
145 instance Show RunResult
147 driveGhc :: Opts -> [FilePath] -> [(FilePath, String)] ->
148 Ghc ([(String, HRule)])
149 driveGhc o allfiles hakefiles = do
151 dflags <- getSessionDynFlags
152 let dflags' = foldl xopt_set dflags [ Opt_DeriveDataTypeable ]
153 _ <- setSessionDynFlags dflags'{
154 importPaths = module_paths,
155 hiDir = Just "./hake",
156 objectDir = Just "./hake"
159 -- Set compilation targets
160 targets <- mapM (\m -> guessTarget m Nothing) source_modules
166 ([IIDecl $ simpleImportDecl $ mkModuleName m |
168 [IIDecl $ (simpleImportDecl $ mkModuleName m) {
169 ideclQualified = True
170 } | m <- qualified_modules])
172 mapM evaluate hakefiles
175 module_paths = [ (opt_installdir o) </> "hake", ".",
176 (opt_bfsourcedir o) </> "hake" ]
177 source_modules = [ "HakeTypes", "RuleDefs", "Path", "Args", "Config" ]
178 modules = [ "Prelude", "HakeTypes", "RuleDefs", "Path", "Args" ]
179 qualified_modules = [ "Config", "Data.List" ]
181 evaluate :: (FilePath, String) -> Ghc ((String, HRule))
182 evaluate (hake_name, hake_raw) = do
186 prettyPrintWithMode (defaultMode {layout = PPNoLayout}) $
187 wrapHake hake_name hake_expr
189 val <- dynCompileExpr $ hake_wrapped ++ " :: [String] -> HRule"
190 liftIO $ putStrLn ( "Success: " ++ hake_name )
191 let rule = fromDyn val (\_ -> Error "failed")
193 resolveRelativePaths o (rule allfiles) hake_name
194 return $ (hake_name, resolved_rule)
195 Right hake_error -> do
196 return $ (hake_name, Error "failed")
198 hake_parse = parseHake (hake_name, hake_raw)
200 evalHakeFiles :: Opts -> [FilePath] -> [(FilePath, String)] ->
201 IO ([(String, HRule)])
202 evalHakeFiles o allfiles hakefiles =
203 defaultErrorHandler defaultFatalMessager defaultFlushOut $
204 runGhc (Just libdir) $
205 driveGhc o allfiles hakefiles
207 parseHake :: (FilePath, String) -> Either Exp HakeError
208 parseHake (filename, contents) =
211 ParseFailed loc str ->
212 Right $ HakeError (show loc ++ ": " ++ str) 2
217 parseFilename = filename,
218 baseLanguage = Haskell2010 })
221 wrapHake :: FilePath -> Exp -> Exp
222 wrapHake hakefile hake_exp =
224 Lambda dummy_loc [PVar (Ident "allfiles")] (
229 [PVar (Ident "fn"), PVar (Ident "arg")]
232 (Paren (App (App (App (Var (UnQual (Ident "fn")))
233 (Var (UnQual (Ident "allfiles"))))
234 (Lit (String hakefile)))
235 (Var (UnQual (Ident "arg"))))))
244 (App (App (App (Paren (App (Var (UnQual (Ident "buildFunction")))
245 (Var (UnQual (Ident "a")))))
246 (Var (UnQual (Ident "allfiles"))))
247 (Lit (String hakefile)))
248 (Var (UnQual (Ident "a")))))
251 (Paren (App (Con (UnQual (Ident "Rules")))
255 dummy_loc = SrcLoc { srcFilename = "<hake internal>",
256 srcLine = 0, srcColumn = 0 }
258 makefilePreamble :: Handle -> Opts -> [String] -> IO ()
259 makefilePreamble h opts args =
261 ([ "# This Makefile is generated by Hake. Do not edit!",
263 "# Hake was invoked with the following command line args:" ] ++
264 [ "# " ++ a | a <- args ] ++
266 "SRCDIR=" ++ (opt_sourcedir opts),
267 "HAKE_ARCHS=" ++ (concat $ intersperse " " Config.architectures),
268 "include ./symbolic_targets.mk" ])
270 -- a rule is included if it has only "special" architectures and enabled architectures
271 allowedArchs :: [String] -> Bool
272 allowedArchs = all (\a -> a `elem` (Config.architectures ++ specialArchitectures))
273 where specialArchitectures = ["", "src", "hake", "root", "tools", "docs"]
275 makefileSection :: Handle -> Opts -> [FilePath] ->
276 (String, HRule) -> IO (S.Set FilePath)
277 makefileSection h opts allfiles (hake_name, rule) = do
278 hPutStrLn h $ "# From: " ++ hake_name ++ "\n"
281 makefileRule :: Handle -> HRule -> IO (S.Set FilePath)
282 makefileRule h (Error s) = do
283 hPutStrLn h $ "$(error " ++ s ++ ")\n"
285 makefileRule h (Rules rules) = do
286 dir_lists <- mapM (makefileRule h) rules
287 return $ S.unions dir_lists
288 makefileRule h (Include token) = do
289 when (allowedArchs [frArch token]) $
290 mapM_ (hPutStrLn h) [
291 "ifeq ($(MAKECMDGOALS),clean)",
292 "else ifeq ($(MAKECMDGOALS),rehake)",
293 "else ifeq ($(MAKECMDGOALS),Makefile)",
295 "include " ++ (formatToken token),
299 makefileRule h (HakeTypes.Rule tokens) =
300 if allowedArchs (map frArch tokens)
301 then makefileRuleInner h tokens False
303 makefileRule h (Phony name double_colon tokens) = do
304 hPutStrLn h $ ".PHONY: " ++ name
305 makefileRuleInner h (Target "build" name : tokens) double_colon
307 printTokens :: Handle -> S.Set RuleToken -> IO ()
308 printTokens h tokens =
309 S.foldr (\t m -> hPutStr h (formatToken t) >> m) (return ()) tokens
311 printDirs :: Handle -> S.Set FilePath -> IO ()
313 S.foldr (\d m -> hPutStr h (d ++ " ") >> m) (return ()) dirs
315 makefileRuleInner :: Handle -> [RuleToken] -> Bool -> IO (S.Set FilePath)
316 makefileRuleInner h tokens double_colon = do
317 if S.null (ruleOutputs compiledRule)
319 hPutStr h "# hake: omitted rule with no output: "
322 printTokens h $ ruleOutputs compiledRule
323 if double_colon then hPutStr h ":: " else hPutStr h ": "
324 printTokens h $ ruleDepends compiledRule
325 printDirs h $ ruleDirs compiledRule
326 when (not (S.null (rulePreDepends compiledRule))) $ do
328 printTokens h $ rulePreDepends compiledRule
332 compiledRule = compileRule tokens
334 doBody :: IO (S.Set FilePath)
336 when (ruleBody compiledRule /= []) $ do
338 mapM_ (hPutStr h . formatToken) $ ruleBody compiledRule
340 return $ ruleDirs compiledRule
343 --- Functions to resolve relative path names in rules.
345 --- First, the outer function: resolve path names in an HRule. The
346 --- third argument, 'root', is frequently the pathname of the Hakefile
347 --- relative to the source tree - since relative pathnames in
348 --- Hakefiles are interpreted relative to the Hakefile location.
350 resolveRelativePaths :: Opts -> HRule -> String -> HRule
351 resolveRelativePaths o (Rules hrules) root
352 = Rules [ resolveRelativePaths o r root | r <- hrules ]
353 resolveRelativePaths o (HakeTypes.Rule tokens) root
354 = HakeTypes.Rule [ resolveRelativePath o t root | t <- tokens ]
355 resolveRelativePaths o (Include token) root
356 = Include ( resolveRelativePath o token root )
357 resolveRelativePaths o (Error s) root
359 resolveRelativePaths o (Phony name dbl tokens) root
360 = Phony name dbl [ resolveRelativePath o t root | t <- tokens ]
362 --- Now resolve at the level of individual rule tokens. At this
363 --- level, we need to take into account the tree (source, build, or
365 resolveRelativePath :: Opts -> RuleToken -> String -> RuleToken
366 resolveRelativePath o (In t a f) root =
367 (In t a (resolveRelativePathName o t a f root))
368 resolveRelativePath o (Out a f) root =
369 (Out a (resolveRelativePathName o BuildTree a f root))
370 resolveRelativePath o (Dep t a f) root =
371 (Dep t a (resolveRelativePathName o t a f root))
372 resolveRelativePath o (NoDep t a f) root =
373 (NoDep t a (resolveRelativePathName o t a f root))
374 resolveRelativePath o (PreDep t a f) root =
375 (PreDep t a (resolveRelativePathName o t a f root))
376 resolveRelativePath o (Target a f) root =
377 (Target a (resolveRelativePathName o BuildTree a f root))
378 resolveRelativePath _ (Str s) _ = (Str s)
379 resolveRelativePath _ (NStr s) _ = (NStr s)
380 resolveRelativePath _ (ErrorMsg s) _ = (ErrorMsg s)
381 resolveRelativePath _ NL _ = NL
383 --- Now we get down to the nitty gritty. We have, in order:
384 --- o: The options in force.
385 --- t: The tree (source, build, or install)
386 --- a: The architecture (e.g. armv7)
387 --- p: The pathname we want to resolve to a full path, and
388 --- h: The dirname of the Hakefile in which it occurs.
389 --- If the tree is SrcTree or the architecture is "root", everything
390 --- is relative to the top-level directory for that tree. Otherwise,
391 --- it's relative to the top-level directory plus the architecture.
392 resolveRelativePathName :: Opts -> TreeRef -> String -> String -> String -> String
394 resolveRelativePathName o SrcTree "root" f h =
395 resolveRelativePathName' ((opt_sourcedir o)) f h
396 resolveRelativePathName o BuildTree "root" f h =
397 resolveRelativePathName' "." f h
398 resolveRelativePathName o InstallTree "root" f h =
399 resolveRelativePathName' ((opt_installdir o)) f h
401 resolveRelativePathName o SrcTree a f h =
402 resolveRelativePathName' (opt_sourcedir o) f h
403 resolveRelativePathName o BuildTree a f h =
404 resolveRelativePathName' ("." </> a) f h
405 resolveRelativePathName o InstallTree a f h =
406 resolveRelativePathName' ((opt_installdir o) </> a) f h
408 --- This is where the work is done: take 'hd' (pathname relative to
409 --- us of the Hakefile) and resolve the filename we're interested in
410 --- relative to this. This gives us a pathname relative to some root
411 --- of some architecture tree, then return this relative to the actual
412 --- tree we're interested in. It's troubling that this takes more
413 --- bytes to explain than to code.
414 --- d: Pathname of top directory of the tree (source, build, install)
415 --- f: Filename we are interested in, relative to 'root' below
416 --- hd: Directory containing the Hakefile
418 resolveRelativePathName' d f hd =
419 let af = Path.relToFile f hd
420 rf = Path.makeRel $ Path.relToDir af "/"
421 in Path.relToDir rf d
423 makeHakeDeps :: Handle -> Opts -> [String] -> IO ()
424 makeHakeDeps h o l = do
426 hPutStrLn h ".DELETE_ON_ERROR:\n" -- this applies to all targets in the Makefile
428 hake = resolveRelativePath o (In InstallTree "root" "/hake/hake") ""
429 makefile = resolveRelativePath o (Out "root" (opt_makefilename o)) "/Hakefile"
430 rule = HakeTypes.Rule
432 Str "--source-dir", Str (opt_sourcedir o),
433 Str "--install-dir", Str (opt_installdir o),
434 Str "--output-filename", makefile
436 [ Dep SrcTree "root" h | h <- l ]
439 makeDirectories :: Handle -> S.Set FilePath -> IO ()
440 makeDirectories h dirs = do
441 hPutStrLn h "# Directories follow"
442 mapM_ (makeDir h) (S.toList (S.delete ("." </> ".marker") dirs))
444 makeDir :: Handle -> FilePath -> IO ()
446 hPutStrLn h $ "hake_dirs: " ++ dir ++ "\n"
447 hPutStrLn h $ dir ++ ":"
448 hPutStrLn h $ "\tmkdir -p " ++ (takeDirectory dir)
449 hPutStrLn h $ "\ttouch " ++ dir
452 scanTokens :: [RuleToken] -> (S.Set RuleToken, S.Set RuleToken,
453 S.Set RuleToken, [RuleToken],
455 scanTokens [] = (S.empty, S.empty, S.empty, [], S.empty)
458 Out _ f -> (S.insert t outs, deps, predeps, body', dirs' f)
459 Target _ f -> (S.insert t outs, deps, predeps, body', dirs' f)
460 In _ _ f -> (outs, S.insert t deps, predeps, body', dirs' f)
461 Dep _ _ f -> (outs, S.insert t deps, predeps, body', dirs' f)
462 PreDep _ _ f -> (outs, deps, S.insert t predeps, body', dirs' f)
463 NoDep _ _ f -> (outs, deps, predeps, body', dirs' f)
464 _ -> (outs, deps, predeps, body', dirs)
466 (outs, deps, predeps, body, dirs) = scanTokens ts
467 body' = if inRule t then t:body else body
468 dirs' f = if Path.isBelow (takeDirectory f) "." &&
469 takeDirectory f /= "."
470 then S.insert (dirOf f) dirs else dirs
472 dirOf :: FilePath -> FilePath
473 dirOf f = (takeDirectory f) </> ".marker"
478 ruleOutputs :: S.Set RuleToken,
479 ruleDepends :: S.Set RuleToken,
480 rulePreDepends :: S.Set RuleToken,
481 ruleBody :: [RuleToken],
482 ruleDirs :: S.Set FilePath
485 compileRule :: [RuleToken] -> CompiledRule
490 rulePreDepends = predeps,
495 (outs, deps, predeps, body, dirs) = scanTokens tokens
500 gc_stats <- getGCStats
501 putStrLn $ show (currentBytesUsed gc_stats) ++ " - " ++
502 show (numGcs gc_stats) ++ " - " ++
503 show (maxBytesUsed gc_stats) ++ " - " ++
504 show (wallSeconds gc_stats)
508 -- parse arguments; architectures default to config file
509 args <- liftIO $ System.Environment.getArgs
510 let o1 = parse_arguments args
511 al = if opt_architectures o1 == []
512 then Config.architectures
513 else opt_architectures o1
514 opts = o1 { opt_architectures = al }
516 when (opt_usage_error opts) $
517 throwError (HakeError usage 1)
519 -- sanity-check configuration settings
520 -- this is currently known at compile time, but might not always be!
521 when (isJust configErrors) $
522 throwError (HakeError ("Error in configuration: " ++
523 (fromJust configErrors)) 2)
525 liftIO $ putStrLn ("Source directory: " ++ opt_sourcedir opts)
526 liftIO $ putStrLn ("BF Source directory: " ++ opt_bfsourcedir opts)
527 liftIO $ putStrLn ("Install directory: " ++ opt_installdir opts)
531 liftIO $ putStrLn "Reading directory tree..."
532 (allfiles, hakefiles) <- liftIO $ listFiles (opt_sourcedir opts)
536 rules <- liftIO $ evalHakeFiles opts allfiles hakefiles
537 liftIO $ putStrLn $ show (length rules)
541 liftIO $ putStrLn $ "Generating " ++ (opt_makefilename opts)
542 makefile <- liftIO $ openFile(opt_makefilename opts) WriteMode
543 liftIO $ makefilePreamble makefile opts args
544 liftIO $ makeHakeDeps makefile opts $ map fst hakefiles
545 dirs <- liftIO $ mapM (makefileSection makefile opts allfiles) rules
546 liftIO $ makeDirectories makefile (S.unions dirs)
554 r <- runErrorT $ body `catchError` handleFailure
557 handleFailure (HakeError str n) = do
558 liftIO $ putStrLn str
559 liftIO $ exitWith (ExitFailure n)