Replaced old hake
[barrelfish] / hake / Main.hs
1 import Control.Monad.Error
2
3 import Data.Dynamic
4 import Data.List
5 import Data.Maybe
6 import qualified Data.Set as S
7
8 import System.Directory
9 import System.Environment
10 import System.Exit
11 import System.FilePath
12 import System.IO
13 import System.Mem
14
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))
20 import GHC.Stats
21
22 import Language.Haskell.Exts
23
24 import RuleDefs
25 import HakeTypes
26 import qualified Args
27 import qualified Config
28 import qualified Path
29
30 data HakeError = HakeError String Int
31 instance Error HakeError
32 type HakeMonad = ErrorT HakeError IO
33
34 --
35 -- Command line options and parsing code
36 --
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
44                  }
45           deriving (Show,Eq)
46                    
47 parse_arguments :: [String] -> Opts
48 parse_arguments [] =
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 = [],
55          opt_verbosity = 1 }
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 ) = 
69   let 
70     o2 = parse_arguments t
71     arches = (a : opt_architectures o2)
72   in
73     o2 { opt_architectures = arches }
74 parse_arguments _ = 
75   (parse_arguments []) { opt_usage_error = True }
76
77 usage :: String
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)",
82                   "   --quiet",
83                   "   --verbose"
84                 ]
85
86 -- check the configuration options, returning an error string if they're insane
87 configErrors :: Maybe String
88 configErrors
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."
96     | otherwise =
97         Nothing
98     where
99         unknownArchs = Config.architectures \\ Args.allArchitectures
100
101 --
102 -- Walk all over a directory tree and build a complete list of pathnames
103 --
104 listFiles :: FilePath -> IO ([FilePath], [(FilePath, String)])
105 listFiles root = do
106     isdir <- doesDirectoryExist root
107     if isdir then do
108         children <- getDirectoryContents root
109         walkchildren children
110     else
111         return ([], [])
112     where
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)
119
120         walkchild :: FilePath -> IO ([FilePath], [(FilePath, String)])
121         walkchild child = do
122             if ignore child
123             then return ([], [])
124             else do
125                 (allfiles, hakefiles) <- listFiles (root </> child)
126                 hake <- maybeHake child
127                 return $ ((root </> child) : allfiles,
128                           hake ++ hakefiles)
129             where
130                 maybeHake "Hakefile" = do
131                     contents <- readFile (root </> child)
132                     return [(root </> child, contents)]
133                 maybeHake _ = return []
134
135         ignore :: FilePath -> Bool
136         ignore "."          = True
137         ignore ".."         = True
138         ignore "CMakeFiles" = True
139         ignore ".hg"        = True
140         ignore "build"      = True
141         ignore ".git"       = True
142         ignore _            = False
143
144 instance Show SuccessFlag
145 instance Show RunResult
146
147 driveGhc :: Opts -> [FilePath] -> [(FilePath, String)] ->
148             Ghc ([(String, HRule)])
149 driveGhc o allfiles hakefiles = do
150     -- Set the RTS flags
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"
157     }
158
159     -- Set compilation targets
160     targets <- mapM (\m -> guessTarget m Nothing) source_modules
161     setTargets targets
162     load LoadAllTargets
163
164     -- Import modules
165     setContext
166         ([IIDecl $ simpleImportDecl $ mkModuleName m |
167             m <- modules] ++
168          [IIDecl $ (simpleImportDecl $ mkModuleName m) {
169                 ideclQualified = True
170           } | m <- qualified_modules])
171
172     mapM evaluate hakefiles
173
174     where
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" ]
180
181         evaluate :: (FilePath, String) -> Ghc ((String, HRule))
182         evaluate (hake_name, hake_raw) = do
183             case hake_parse of
184                 Left hake_expr -> do
185                     let hake_wrapped =
186                             prettyPrintWithMode (defaultMode {layout = PPNoLayout}) $
187                                 wrapHake hake_name hake_expr
188
189                     val <- dynCompileExpr $ hake_wrapped ++ " :: [String] -> HRule"
190                     liftIO $ putStrLn ( "Success: " ++ hake_name )
191                     let rule = fromDyn val (\_ -> Error "failed")
192                     let resolved_rule =
193                             resolveRelativePaths o (rule allfiles) hake_name
194                     return $ (hake_name, resolved_rule)
195                 Right hake_error -> do
196                     return $ (hake_name, Error "failed")
197             where
198                 hake_parse = parseHake (hake_name, hake_raw)
199
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
206
207 parseHake :: (FilePath, String) -> Either Exp HakeError
208 parseHake (filename, contents) =
209     case result of
210         ParseOk e -> Left e
211         ParseFailed loc str ->
212             Right $ HakeError (show loc ++ ": " ++ str) 2
213     where
214         result =
215             parseExpWithMode
216                 (defaultParseMode {
217                     parseFilename = filename,
218                     baseLanguage = Haskell2010 })
219                 contents
220
221 wrapHake :: FilePath -> Exp -> Exp
222 wrapHake hakefile hake_exp =
223     Paren (
224     Lambda dummy_loc [PVar (Ident "allfiles")] (
225     Let (BDecls
226         [FunBind [Match
227             dummy_loc
228             (Ident "find")
229             [PVar (Ident "fn"), PVar (Ident "arg")]
230             Nothing
231             (UnGuardedRhs
232                 (Paren (App (App (App (Var (UnQual (Ident "fn")))
233                                       (Var (UnQual (Ident "allfiles"))))
234                                  (Lit (String hakefile)))
235                        (Var (UnQual (Ident "arg"))))))
236             (BDecls [])],
237
238         FunBind [Match
239             dummy_loc
240             (Ident "build")
241             [PVar (Ident "a")]
242             Nothing
243             (UnGuardedRhs
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")))))
249             (BDecls [])]
250         ])
251         (Paren (App (Con (UnQual (Ident "Rules")))
252                     hake_exp))
253     ))
254     where
255         dummy_loc = SrcLoc { srcFilename = "<hake internal>",
256                                 srcLine = 0, srcColumn = 0 }
257
258 makefilePreamble :: Handle -> Opts -> [String] -> IO ()
259 makefilePreamble h opts args = 
260     mapM_ (hPutStrLn h)
261           ([ "# This Makefile is generated by Hake.  Do not edit!",
262              "# ",
263              "# Hake was invoked with the following command line args:" ] ++
264            [ "#        " ++ a | a <- args ] ++
265            [ "# ",
266              "SRCDIR=" ++ (opt_sourcedir opts),
267              "HAKE_ARCHS=" ++ (concat $ intersperse " " Config.architectures),
268              "include ./symbolic_targets.mk" ])
269
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"]
274
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"
279     makefileRule h rule
280
281 makefileRule :: Handle -> HRule -> IO (S.Set FilePath)
282 makefileRule h (Error s) = do
283     hPutStrLn h $ "$(error " ++ s ++ ")\n"
284     return S.empty
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)",
294             "else",
295             "include " ++ (formatToken token),
296             "endif",
297             "" ]
298     return S.empty
299 makefileRule h (HakeTypes.Rule tokens) =
300     if allowedArchs (map frArch tokens)
301         then makefileRuleInner h tokens False
302         else return S.empty
303 makefileRule h (Phony name double_colon tokens) = do
304     hPutStrLn h $ ".PHONY: " ++ name
305     makefileRuleInner h (Target "build" name : tokens) double_colon
306
307 printTokens :: Handle -> S.Set RuleToken -> IO ()
308 printTokens h tokens =
309     S.foldr (\t m -> hPutStr h (formatToken t) >> m) (return ()) tokens
310
311 printDirs :: Handle -> S.Set FilePath -> IO ()
312 printDirs h dirs =
313     S.foldr (\d m -> hPutStr h (d ++ " ") >> m) (return ()) dirs
314
315 makefileRuleInner :: Handle -> [RuleToken] -> Bool -> IO (S.Set FilePath)
316 makefileRuleInner h tokens double_colon = do
317     if S.null (ruleOutputs compiledRule)
318     then do
319         hPutStr h "# hake: omitted rule with no output: "
320         doBody
321     else do
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
327             hPutStr h " | "
328             printTokens h $ rulePreDepends compiledRule
329         hPutStrLn h ""
330         doBody
331     where
332         compiledRule = compileRule tokens
333
334         doBody :: IO (S.Set FilePath)
335         doBody = do
336             when (ruleBody compiledRule /= []) $ do
337                 hPutStr h "\t"
338                 mapM_ (hPutStr h . formatToken) $ ruleBody compiledRule
339             hPutStrLn h "\n"
340             return $ ruleDirs compiledRule
341
342 ---
343 --- Functions to resolve relative path names in rules. 
344 ---
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.
349 ---
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 
358     = Error s
359 resolveRelativePaths o (Phony name dbl tokens) root 
360     = Phony name dbl [ resolveRelativePath o t root | t <- tokens ]
361
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
364 --- install).
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
382
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
393
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
400
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
407
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
417 ---   
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
422
423 makeHakeDeps :: Handle -> Opts -> [String] -> IO ()
424 makeHakeDeps h o l = do
425     makefileRule h rule
426     hPutStrLn h ".DELETE_ON_ERROR:\n" -- this applies to all targets in the Makefile
427     where
428         hake = resolveRelativePath o (In InstallTree "root" "/hake/hake") ""
429         makefile = resolveRelativePath o (Out "root" (opt_makefilename o)) "/Hakefile"
430         rule = HakeTypes.Rule
431                     ( [ hake, 
432                         Str "--source-dir", Str (opt_sourcedir o),
433                         Str "--install-dir", Str (opt_installdir o),
434                         Str "--output-filename", makefile
435                       ] ++
436                       [ Dep SrcTree "root" h | h <- l ]
437                     )
438
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))
443
444 makeDir :: Handle -> FilePath -> IO ()
445 makeDir h dir = do
446     hPutStrLn h $ "hake_dirs: " ++ dir ++ "\n"
447     hPutStrLn h $ dir ++ ":"
448     hPutStrLn h $ "\tmkdir -p " ++ (takeDirectory dir)
449     hPutStrLn h $ "\ttouch " ++ dir
450     hPutStrLn h ""
451
452 scanTokens :: [RuleToken] -> (S.Set RuleToken, S.Set RuleToken,
453                               S.Set RuleToken, [RuleToken],
454                               S.Set FilePath)
455 scanTokens [] = (S.empty, S.empty, S.empty, [], S.empty)
456 scanTokens (t:ts) =
457     case t of
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)
465     where
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
471
472         dirOf :: FilePath -> FilePath
473         dirOf f = (takeDirectory f) </> ".marker"
474
475
476 data CompiledRule =
477     CompiledRule {
478         ruleOutputs    :: S.Set RuleToken,
479         ruleDepends    :: S.Set RuleToken,
480         rulePreDepends :: S.Set RuleToken,
481         ruleBody       :: [RuleToken],
482         ruleDirs       :: S.Set FilePath
483     }
484
485 compileRule :: [RuleToken] -> CompiledRule
486 compileRule tokens
487     = CompiledRule {
488         ruleOutputs    = outs,
489         ruleDepends    = deps,
490         rulePreDepends = predeps,
491         ruleBody       = body,
492         ruleDirs       = dirs
493         }
494     where
495         (outs, deps, predeps, body, dirs) = scanTokens tokens
496
497 gcStats :: IO ()
498 gcStats = do
499     performGC
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)
505
506 body :: HakeMonad ()
507 body =  do
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 }
515
516     when (opt_usage_error opts) $
517         throwError (HakeError usage 1)
518
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)
524
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)
528
529     liftIO gcStats
530
531     liftIO $ putStrLn "Reading directory tree..."
532     (allfiles, hakefiles) <- liftIO $ listFiles (opt_sourcedir opts)
533
534     liftIO gcStats
535
536     rules <- liftIO $ evalHakeFiles opts allfiles hakefiles
537     liftIO $ putStrLn $ show (length rules)
538
539     liftIO gcStats
540
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)
547
548     liftIO gcStats
549
550     return ()
551
552 main :: IO () 
553 main = do
554     r <- runErrorT $ body `catchError` handleFailure
555     exitWith ExitSuccess
556     where
557         handleFailure (HakeError str n) = do
558             liftIO $ putStrLn str
559             liftIO $ exitWith (ExitFailure n)