Generates a Makefile
[barrelfish] / hake / Hake2.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, String)] -> Ghc ([(String, [String] -> HRule)])
148 driveGhc o hakefiles = do
149     -- Set the RTS flags
150     dflags <- getSessionDynFlags
151     let dflags' = foldl xopt_set dflags [ Opt_DeriveDataTypeable ]
152     _ <- setSessionDynFlags dflags'{
153         importPaths = module_paths,
154         hiDir = Just "./hake",
155         objectDir = Just "./hake"
156     }
157
158     -- Set compilation targets
159     targets <- mapM (\m -> guessTarget m Nothing) source_modules
160     setTargets targets
161     load LoadAllTargets
162
163     -- Import modules
164     setContext
165         ([IIDecl $ simpleImportDecl $ mkModuleName m |
166             m <- modules] ++
167          [IIDecl $ (simpleImportDecl $ mkModuleName m) {
168                 ideclQualified = True
169           } | m <- qualified_modules])
170
171     mapM evaluate hakefiles
172
173     where
174         module_paths = [ (opt_installdir o) </> "hake", ".", 
175                          (opt_bfsourcedir o) </> "hake" ]
176         source_modules = [ "HakeTypes", "RuleDefs", "Path", "Args", "Config" ]
177         modules = [ "Prelude", "HakeTypes", "RuleDefs", "Path", "Args" ]
178         qualified_modules = [ "Config", "Data.List" ]
179
180         evaluate :: (FilePath, String) -> Ghc ((String, [String] -> HRule))
181         evaluate (hake_name, hake_raw) = do
182             case hake_parse of
183                 Left hake_expr -> do
184                     let hake_wrapped =
185                             prettyPrintWithMode (defaultMode {layout = PPNoLayout}) $
186                                 wrapHake hake_name hake_expr
187
188                     val <- dynCompileExpr $ hake_wrapped ++ " :: [String] -> HRule"
189                     liftIO $ putStrLn ( "Success: " ++ hake_name )
190                     return $ (hake_name, fromDyn val (\_ -> Error "failed"))
191                 Right hake_error -> do
192                     return $ (hake_name, \_ -> Error "failed")
193             where
194                 hake_parse = parseHake (hake_name, hake_raw)
195
196 evalHakeFiles :: Opts -> [(FilePath, String)] ->
197                  IO ([(String, [String] -> HRule)])
198 evalHakeFiles o hakefiles =
199     defaultErrorHandler defaultFatalMessager defaultFlushOut $
200         runGhc (Just libdir) $
201         driveGhc o hakefiles
202
203 parseHake :: (FilePath, String) -> Either Exp HakeError
204 parseHake (filename, contents) =
205     case result of
206         ParseOk e -> Left e
207         ParseFailed loc str ->
208             Right $ HakeError (show loc ++ ": " ++ str) 2
209     where
210         result =
211             parseExpWithMode
212                 (defaultParseMode {
213                     parseFilename = filename,
214                     baseLanguage = Haskell2010 })
215                 contents
216
217 wrapHake :: FilePath -> Exp -> Exp
218 wrapHake hakefile hake_exp =
219     Paren (
220     Lambda dummy_loc [PVar (Ident "allfiles")] (
221     Let (BDecls
222         [FunBind [Match
223             dummy_loc
224             (Ident "find")
225             [PVar (Ident "fn"), PVar (Ident "arg")]
226             Nothing
227             (UnGuardedRhs
228                 (Paren (App (App (App (Var (UnQual (Ident "fn")))
229                                       (Var (UnQual (Ident "allfiles"))))
230                                  (Lit (String hakefile)))
231                        (Var (UnQual (Ident "arg"))))))
232             (BDecls [])],
233
234         FunBind [Match
235             dummy_loc
236             (Ident "build")
237             [PVar (Ident "a")]
238             Nothing
239             (UnGuardedRhs
240                 (App (App (App (Paren (App (Var (UnQual (Ident "buildFunction")))
241                                            (Var (UnQual (Ident "a")))))
242                                (Var (UnQual (Ident "allfiles"))))
243                           (Lit (String hakefile)))
244                      (Var (UnQual (Ident "a")))))
245             (BDecls [])]
246         ])
247         (Paren (App (Con (UnQual (Ident "Rules")))
248                     hake_exp))
249     ))
250     where
251         dummy_loc = SrcLoc { srcFilename = "<hake internal>",
252                                 srcLine = 0, srcColumn = 0 }
253
254 makefilePreamble :: Handle -> Opts -> [String] -> IO ()
255 makefilePreamble h opts args = 
256     mapM_ (hPutStrLn h)
257           ([ "# This Makefile is generated by Hake.  Do not edit!",
258              "# ",
259              "# Hake was invoked with the following command line args:" ] ++
260            [ "#        " ++ a | a <- args ] ++
261            [ "# ",
262              "SRCDIR=" ++ (opt_sourcedir opts),
263              "HAKE_ARCHS=" ++ (concat $ intersperse " " Config.architectures),
264              "include ./symbolic_targets.mk" ])
265
266 -- a rule is included if it has only "special" architectures and enabled architectures
267 allowedArchs :: [String] -> Bool
268 allowedArchs = all (\a -> a `elem` (Config.architectures ++ specialArchitectures))
269     where specialArchitectures = ["", "src", "hake", "root", "tools", "docs"]
270
271 makefileSection :: Handle -> Opts -> [FilePath] ->
272                    (String, [String] -> HRule) -> IO (S.Set FilePath)
273 makefileSection h opts allfiles (hake_name, rule_schema) = do
274     hPutStrLn h $ "# From: " ++ hake_name ++ "\n"
275     makefileRule h $
276         resolveRelativePaths opts (rule_schema allfiles) hake_name
277
278 makefileRule :: Handle -> HRule -> IO (S.Set FilePath)
279 makefileRule h (Error s) = do
280     hPutStrLn h $ "$(error " ++ s ++ ")\n"
281     return S.empty
282 makefileRule h (Rules rules) = do
283     dir_lists <- mapM (makefileRule h) rules
284     return $ S.unions dir_lists
285 makefileRule h (Include token) = do
286     when (allowedArchs [frArch token]) $
287         mapM_ (hPutStrLn h) [
288             "ifeq ($(MAKECMDGOALS),clean)",
289             "else ifeq ($(MAKECMDGOALS),rehake)",
290             "else ifeq ($(MAKECMDGOALS),Makefile)",
291             "else",
292             "include " ++ (formatToken token),
293             "endif",
294             "" ]
295     return S.empty
296 makefileRule h (HakeTypes.Rule tokens) =
297     if allowedArchs (map frArch tokens)
298         then makefileRuleInner h tokens False
299         else return S.empty
300 makefileRule h (Phony name double_colon tokens) = do
301     hPutStrLn h $ ".PHONY: " ++ name
302     makefileRuleInner h (Target "build" name : tokens) double_colon
303
304 printTokens :: Handle -> S.Set RuleToken -> IO ()
305 printTokens h tokens =
306     S.foldr (\t m -> hPutStr h (formatToken t) >> m) (return ()) tokens
307
308 printDirs :: Handle -> S.Set FilePath -> IO ()
309 printDirs h dirs =
310     S.foldr (\d m -> hPutStr h (d ++ " ") >> m) (return ()) dirs
311
312 makefileRuleInner :: Handle -> [RuleToken] -> Bool -> IO (S.Set FilePath)
313 makefileRuleInner h tokens double_colon = do
314     if S.null (ruleOutputs compiledRule)
315     then do
316         hPutStr h "# hake: omitted rule with no output: "
317         doBody
318     else do
319         printTokens h $ ruleOutputs compiledRule
320         if double_colon then hPutStr h ":: " else hPutStr h ": "
321         printTokens h $ ruleDepends compiledRule
322         printDirs h $ ruleDirs compiledRule
323         when (not (S.null (rulePreDepends compiledRule))) $ do
324             hPutStr h " | "
325             printTokens h $ rulePreDepends compiledRule
326         hPutStrLn h ""
327         doBody
328     where
329         compiledRule = compileRule tokens
330
331         doBody :: IO (S.Set FilePath)
332         doBody = do
333             when (ruleBody compiledRule /= []) $ do
334                 hPutStr h "\t"
335                 mapM_ (hPutStr h . formatToken) $ ruleBody compiledRule
336             hPutStrLn h "\n"
337             return $ ruleDirs compiledRule
338
339 ---
340 --- Functions to resolve relative path names in rules. 
341 ---
342 --- First, the outer function: resolve path names in an HRule. The
343 --- third argument, 'root', is frequently the pathname of the Hakefile
344 --- relative to the source tree - since relative pathnames in
345 --- Hakefiles are interpreted relative to the Hakefile location.
346 ---
347 resolveRelativePaths :: Opts -> HRule -> String -> HRule
348 resolveRelativePaths o (Rules hrules) root 
349     = Rules [ resolveRelativePaths o r root | r <- hrules ]
350 resolveRelativePaths o (HakeTypes.Rule tokens) root
351     = HakeTypes.Rule [ resolveRelativePath o t root | t <- tokens ]
352 resolveRelativePaths o (Include token) root
353     = Include ( resolveRelativePath o token root )
354 resolveRelativePaths o (Error s) root 
355     = Error s
356 resolveRelativePaths o (Phony name dbl tokens) root 
357     = Phony name dbl [ resolveRelativePath o t root | t <- tokens ]
358
359 --- Now resolve at the level of individual rule tokens.  At this
360 --- level, we need to take into account the tree (source, build, or
361 --- install).
362 resolveRelativePath :: Opts -> RuleToken -> String -> RuleToken
363 resolveRelativePath o (In t a f) root = 
364     (In t a (resolveRelativePathName o t a f root))
365 resolveRelativePath o (Out a f) root = 
366     (Out a (resolveRelativePathName o BuildTree a f root))
367 resolveRelativePath o (Dep t a f) root = 
368     (Dep t a (resolveRelativePathName o t a f root))
369 resolveRelativePath o (NoDep t a f) root = 
370     (NoDep t a (resolveRelativePathName o t a f root))
371 resolveRelativePath o (PreDep t a f) root = 
372     (PreDep t a (resolveRelativePathName o t a f root))
373 resolveRelativePath o (Target a f) root = 
374     (Target a (resolveRelativePathName o BuildTree a f root))
375 resolveRelativePath _ (Str s) _ = (Str s)
376 resolveRelativePath _ (NStr s) _ = (NStr s)
377 resolveRelativePath _ (ErrorMsg s) _ = (ErrorMsg s)
378 resolveRelativePath _ NL _ = NL
379
380 --- Now we get down to the nitty gritty.  We have, in order:
381 ---   o: The options in force.
382 ---   t: The tree (source, build, or install)
383 ---   a: The architecture (e.g. armv7)
384 ---   p: The pathname we want to resolve to a full path, and
385 ---   h: The dirname of the Hakefile in which it occurs.
386 --- If the tree is SrcTree or the architecture is "root", everything
387 --- is relative to the top-level directory for that tree.  Otherwise,
388 --- it's relative to the top-level directory plus the architecture.
389 resolveRelativePathName :: Opts -> TreeRef -> String -> String -> String -> String
390
391 resolveRelativePathName o SrcTree "root" f h = 
392     resolveRelativePathName' ((opt_sourcedir o)) f h
393 resolveRelativePathName o BuildTree "root" f h = 
394     resolveRelativePathName' "." f h
395 resolveRelativePathName o InstallTree "root" f h = 
396     resolveRelativePathName' ((opt_installdir o)) f h
397
398 resolveRelativePathName o SrcTree a f h =
399     resolveRelativePathName' (opt_sourcedir o) f h
400 resolveRelativePathName o BuildTree a f h =
401     resolveRelativePathName' ("." </> a) f h
402 resolveRelativePathName o InstallTree a f h =
403     resolveRelativePathName' ((opt_installdir o) </> a) f h
404
405 --- This is where the work is done: take 'hd' (pathname relative to
406 --- us of the Hakefile) and resolve the filename we're interested in
407 --- relative to this.  This gives us a pathname relative to some root
408 --- of some architecture tree, then return this relative to the actual
409 --- tree we're interested in.  It's troubling that this takes more
410 --- bytes to explain than to code.
411 ---   d:    Pathname of top directory of the tree (source, build, install)
412 ---   f:    Filename we are interested in, relative to 'root' below
413 ---   hd:   Directory containing the Hakefile
414 ---   
415 resolveRelativePathName' d f hd = 
416     let af = Path.relToFile f hd
417         rf = Path.makeRel $ Path.relToDir af "/" 
418     in Path.relToDir rf d
419
420 makeHakeDeps :: Handle -> Opts -> [String] -> IO ()
421 makeHakeDeps h o l = do
422     makefileRule h rule
423     hPutStrLn h ".DELETE_ON_ERROR:\n" -- this applies to all targets in the Makefile
424     where
425         hake = resolveRelativePath o (In InstallTree "root" "/hake/hake") ""
426         makefile = resolveRelativePath o (Out "root" (opt_makefilename o)) "/Hakefile"
427         rule = HakeTypes.Rule
428                     ( [ hake, 
429                         Str "--source-dir", Str (opt_sourcedir o),
430                         Str "--install-dir", Str (opt_installdir o),
431                         Str "--output-filename", makefile
432                       ] ++
433                       [ Dep SrcTree "root" h | h <- l ]
434                     )
435
436 makeDirectories :: Handle -> S.Set FilePath -> IO ()
437 makeDirectories h dirs = do
438     hPutStrLn h "# Directories follow"
439     mapM_ (makeDir h) (S.toList (S.delete ("." </> ".marker") dirs))
440
441 makeDir :: Handle -> FilePath -> IO ()
442 makeDir h dir = do
443     hPutStrLn h $ "hake_dirs: " ++ dir ++ "\n"
444     hPutStrLn h $ dir ++ ":"
445     hPutStrLn h $ "\tmkdir -p " ++ (takeDirectory dir)
446     hPutStrLn h $ "\ttouch " ++ dir
447     hPutStrLn h ""
448
449 scanTokens :: [RuleToken] -> (S.Set RuleToken, S.Set RuleToken,
450                               S.Set RuleToken, [RuleToken],
451                               S.Set FilePath)
452 scanTokens [] = (S.empty, S.empty, S.empty, [], S.empty)
453 scanTokens (t:ts) =
454     case t of
455         Out _ f      -> (S.insert t outs, deps, predeps, body',
456                          S.insert (dirOf f) dirs)
457         Target _ f   -> (S.insert t outs, deps, predeps, body',
458                          S.insert (dirOf f) dirs)
459         In _ _ _     -> (outs, S.insert t deps, predeps, body', dirs)
460         Dep _ _ _    -> (outs, S.insert t deps, predeps, body', dirs)
461         PreDep _ _ _ -> (outs, deps, S.insert t predeps, body', dirs)
462         _            -> (outs, deps, predeps, body', dirs)
463     where
464         (outs, deps, predeps, body, dirs) = scanTokens ts
465         body' = if inRule t then t:body else body
466
467         dirOf :: FilePath -> FilePath
468         dirOf f = (takeDirectory f) </> ".marker"
469
470 data CompiledRule =
471     CompiledRule {
472         ruleOutputs    :: S.Set RuleToken,
473         ruleDepends    :: S.Set RuleToken,
474         rulePreDepends :: S.Set RuleToken,
475         ruleBody       :: [RuleToken],
476         ruleDirs       :: S.Set FilePath
477     }
478
479 compileRule :: [RuleToken] -> CompiledRule
480 compileRule tokens
481     = CompiledRule {
482         ruleOutputs    = outs,
483         ruleDepends    = deps,
484         rulePreDepends = predeps,
485         ruleBody       = body,
486         ruleDirs       = dirs
487         }
488     where
489         (outs, deps, predeps, body, dirs) = scanTokens tokens
490
491 gcStats :: IO ()
492 gcStats = do
493     performGC
494     gc_stats <- getGCStats
495     putStrLn $ show (currentBytesUsed gc_stats) ++ " - " ++
496                show (numGcs gc_stats) ++ " - " ++
497                show (maxBytesUsed gc_stats) ++ " - " ++
498                show (wallSeconds gc_stats)
499
500 body :: HakeMonad ()
501 body =  do
502     -- parse arguments; architectures default to config file
503     args <- liftIO $ System.Environment.getArgs
504     let o1 = parse_arguments args
505         al = if opt_architectures o1 == [] 
506              then Config.architectures 
507              else opt_architectures o1
508         opts = o1 { opt_architectures = al }
509
510     when (opt_usage_error opts) $
511         throwError (HakeError usage 1)
512
513     -- sanity-check configuration settings
514     -- this is currently known at compile time, but might not always be!
515     when (isJust configErrors) $
516         throwError (HakeError ("Error in configuration: " ++
517                                (fromJust configErrors)) 2)
518
519     liftIO $ putStrLn ("Source directory: " ++ opt_sourcedir opts)
520     liftIO $ putStrLn ("BF Source directory: " ++ opt_bfsourcedir opts)
521     liftIO $ putStrLn ("Install directory: " ++ opt_installdir opts)
522
523     liftIO gcStats
524
525     liftIO $ putStrLn "Reading directory tree..."
526     (allfiles, hakefiles) <- liftIO $ listFiles (opt_sourcedir opts)
527
528     liftIO gcStats
529
530     rules <- liftIO $ evalHakeFiles opts hakefiles
531     liftIO $ putStrLn $ show (length rules)
532
533     liftIO gcStats
534
535     liftIO $ putStrLn $ "Generating " ++ (opt_makefilename opts)
536     makefile <- liftIO $ openFile(opt_makefilename opts) WriteMode
537     liftIO $ makefilePreamble makefile opts args
538     liftIO $ makeHakeDeps makefile opts $ map fst hakefiles
539     dirs <- liftIO $ mapM (makefileSection makefile opts allfiles) rules
540     liftIO $ makeDirectories makefile (S.unions dirs)
541
542     liftIO gcStats
543
544     return ()
545
546 main :: IO () 
547 main = do
548     r <- runErrorT $ body `catchError` handleFailure
549     exitWith ExitSuccess
550     where
551         handleFailure (HakeError str n) = do
552             liftIO $ putStrLn str
553             liftIO $ exitWith (ExitFailure n)