update tree to use ghc7.4
[barrelfish] / hake / Main.hs
1 {- 
2   Hake: a meta build system for Barrelfish
3
4   Copyright (c) 2009, 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, Haldeneggsteig 4, CH-8092 Zurich. Attn: Systems Group.
10 -}
11   
12
13
14 module Main where
15
16 import System.Environment
17 import System.IO
18 import System.Directory
19 import System.Exit
20 import GHC hiding (Target)
21 import GHC.Paths ( libdir )
22 import DynFlags ( defaultLogAction,
23                   xopt_set,
24                   ExtensionFlag (Opt_DeriveDataTypeable) )
25 import Data.Dynamic
26 import Data.Maybe
27 import Data.List
28 import Control.Monad
29
30 import RuleDefs
31 import HakeTypes
32 import qualified Path
33 import qualified Args
34 import qualified Config
35
36 --
37 -- Command line options and parsing code
38 --
39 data Opts = Opts { opt_makefilename :: String,
40                    opt_installdir :: String,
41                    opt_sourcedir :: String,
42                    opt_bfsourcedir :: String,
43                    opt_usage_error :: Bool,
44                    opt_architectures :: [String],
45                    opt_verbosity :: Integer
46                  }
47           deriving (Show,Eq)
48                    
49 parse_arguments :: [String] -> Opts
50 parse_arguments [] =
51   Opts { opt_makefilename = "Makefile",
52          opt_installdir = Config.install_dir,
53          opt_sourcedir = Config.source_dir,
54          opt_bfsourcedir = Config.source_dir,
55          opt_usage_error = False, 
56          opt_architectures = [],
57          opt_verbosity = 1 }
58 parse_arguments ("--install-dir" : (s : t)) =
59   (parse_arguments t) { opt_installdir = s }
60 parse_arguments ("--source-dir" : s : t) =  
61   (parse_arguments t) { opt_sourcedir = s }
62 parse_arguments ("--bfsource-dir" : s : t) =  
63   (parse_arguments t) { opt_bfsourcedir = s }
64 parse_arguments ("--output-filename" : s : t) =
65   (parse_arguments t) { opt_makefilename = s }
66 parse_arguments ("--quiet" : t ) = 
67   (parse_arguments t) { opt_verbosity = 0 }
68 parse_arguments ("--verbose" : t ) = 
69   (parse_arguments t) { opt_verbosity = 2 }
70 parse_arguments ("--architecture" : a : t ) = 
71   let 
72     o2 = parse_arguments t
73     arches = (a : opt_architectures o2)
74   in
75     o2 { opt_architectures = arches }
76 parse_arguments _ = 
77   (parse_arguments []) { opt_usage_error = True }
78
79 usage :: String
80 usage = unlines [ "Usage: hake <options>",
81                   "   --source-dir <dir> (required)",
82                   "   --bfsource-dir <dir> (defaults to source dir)",
83                   "   --install-dir <dir> (defaults to source dir)",
84                   "   --quiet",
85                   "   --verbose"
86                 ]
87
88 --
89 -- Handy path operator
90 --
91 infix 4 ./.
92 root ./. path = Path.relToDir path root
93
94
95 --
96 -- Walk all over a directory tree and build a complete list of pathnames
97 --
98 listFilesR :: FilePath -> IO [FilePath]
99 listFilesR path = let
100     isDODD :: String -> Bool
101     isDODD f = not $ (isSuffixOf "/." f) 
102                   || (isSuffixOf "/.." f) 
103                   || (isSuffixOf "/.hg" f)
104                   || (isSuffixOf "CMakeFiles" f)
105                   || (isPrefixOf "./build" f)
106
107     listDirs :: [FilePath] -> IO [FilePath]
108     listDirs = filterM doesDirectoryExist 
109
110     listFiles :: [FilePath] -> IO [FilePath]
111     listFiles = filterM doesFileExist
112
113     joinFN :: String -> String -> FilePath
114     -- joinFN p1 p2 = joinPath [p1, p2]
115     joinFN p1 p2 =  p1 ++ "/" ++ p2
116
117     in do
118         allfiles <- getDirectoryContents path
119         no_dots <- filterM (return . isDODD) (map (joinFN path) allfiles)
120         dirs <- listDirs no_dots
121         subdirfiles <- (mapM listFilesR dirs >>= return . concat)
122         files <- listFiles no_dots
123         return $ files ++ subdirfiles
124
125 --
126 -- Return a list of pairs of (Hakefile name, contents)
127 -- 
128 readHakeFiles :: [FilePath] -> IO [ (String,String) ]
129 readHakeFiles [] = return []
130 readHakeFiles (h:hs) = do { r <- readFile h; 
131                             rs <- readHakeFiles hs;
132                             return ((h,r):rs)
133                           }
134 --
135 -- Look for Hakefiles in a list of path names
136 --
137 hakeFiles :: [FilePath] -> [String]
138 hakeFiles f = [ fp | fp <- f, isSuffixOf "/Hakefile" fp ]
139
140 ---
141 --- Functions to resolve relative path names in rules. 
142 ---
143 --- First, the outer function: resolve path names in an HRule. The
144 --- third argument, 'root', is frequently the pathname of the Hakefile
145 --- relative to the source tree - since relative pathnames in
146 --- Hakefiles are interpreted relative to the Hakefile location.
147 ---
148 resolveRelativePaths :: Opts -> HRule -> String -> HRule
149 resolveRelativePaths o (Rules hrules) root 
150     = Rules [ resolveRelativePaths o r root | r <- hrules ]
151 resolveRelativePaths o (Rule tokens) root
152     = Rule [ resolveRelativePath o t root | t <- tokens ]
153 resolveRelativePaths o (Include token) root
154     = Include ( resolveRelativePath o token root )
155 resolveRelativePaths o (Error s) root 
156     = (Error s)
157
158
159 --- Now resolve at the level of individual rule tokens.  At this
160 --- level, we need to take into account the tree (source, build, or
161 --- install).
162 resolveRelativePath :: Opts -> RuleToken -> String -> RuleToken
163 resolveRelativePath o (In t a f) root = 
164     (In t a (resolveRelativePathName o t a f root))
165 resolveRelativePath o (Out a f) root = 
166     (Out a (resolveRelativePathName o BuildTree a f root))
167 resolveRelativePath o (Dep t a f) root = 
168     (Dep t a (resolveRelativePathName o t a f root))
169 resolveRelativePath o (NoDep t a f) root = 
170     (NoDep t a (resolveRelativePathName o t a f root))
171 resolveRelativePath o (PreDep t a f) root = 
172     (PreDep t a (resolveRelativePathName o t a f root))
173 resolveRelativePath o (Target a f) root = 
174     (Target a (resolveRelativePathName o BuildTree a f root))
175 resolveRelativePath _ (Str s) _ = (Str s)
176 resolveRelativePath _ (NStr s) _ = (NStr s)
177 resolveRelativePath _ (ContStr b s1 s2) _ = (ContStr b s1 s2)
178 resolveRelativePath _ (ErrorMsg s) _ = (ErrorMsg s)
179 resolveRelativePath _ NL _ = NL
180
181 --- Now we get down to the nitty gritty.  We have a tree (source,
182 --- build, or install), an architecture (e.g. ARM), a pathname, and
183 --- the pathname of the Hakefile in which it occurs.
184
185 resolveRelativePathName :: Opts -> TreeRef -> String -> String -> String -> String
186 resolveRelativePathName o InstallTree "root" f root = 
187     resolveRelativePathName' ((opt_installdir o)) "root" f root
188 resolveRelativePathName o _ "root" f root = 
189     "." ./. f
190 resolveRelativePathName o SrcTree a f root =
191     resolveRelativePathName' (opt_sourcedir o) a f root
192 resolveRelativePathName o BuildTree a f root =
193     resolveRelativePathName' ("." ./. a) a f root
194 resolveRelativePathName o InstallTree a f root =
195     resolveRelativePathName' ((opt_installdir o) ./. a) a f root
196
197 --- This is where the work is done: take 'root' (pathname relative to
198 --- us of the Hakefile) and resolve the filename we're interested in
199 --- relative to this.  This gives us a pathname relative to some root
200 --- of some architecture tree, then return this relative to the actual
201 --- tree we're interested in.  It's troubling that this takes more
202 --- bytes to explain than to code.
203 resolveRelativePathName' d a f root = 
204     let af = Path.relToFile f root
205         rf = Path.makeRel $ Path.relToDir af "/" 
206     in Path.relToDir rf d
207
208 --
209 -- Generating a list of build directories
210 --
211 makeDirectories :: [(String, HRule)] -> String
212 makeDirectories r = 
213     let alldirs = makeDirs1 (Rules [ rl | (f,rl) <- r ])
214         marker d = d ./. ".marker"
215     in unlines ([ "# Directories follow" ] ++
216                 [ "hake_dirs: " ++ (marker d) ++ "\n\n" ++
217                   (marker d) ++ ": \n" ++
218                   "\tmkdir -p " ++ d ++ "\n" ++
219                   "\ttouch " ++ (marker d) ++ "\n"
220                 | d <- nub alldirs])
221        
222 makeDirs1 :: HRule -> [String]
223 makeDirs1 (Rules hrules) = concat [ makeDirs1 r | r <- hrules]
224 makeDirs1 (Include tok) = 
225     case tokDir tok of
226       Nothing -> []
227       Just d -> [d]
228 makeDirs1 (Rule toks) = [d | Just d <- [ tokDir t | t <- toks ]]
229 makeDirs1 (Error s) = []
230
231 tokDir :: RuleToken -> Maybe String
232 tokDir (In t a f) = tokDir1 f
233 tokDir (Out a f) =  tokDir1 f
234 tokDir (Dep t a f) =  tokDir1 f
235 tokDir (NoDep t a f) =  tokDir1 f
236 tokDir (PreDep t a f) =  tokDir1 f
237 tokDir (Target a f) =  tokDir1 f
238 tokDir (Str s) = Nothing
239 tokDir (NStr s) = Nothing
240 tokDir (ContStr b s1 s2) = Nothing
241 tokDir (ErrorMsg s) = Nothing
242 tokDir NL = Nothing
243
244 tokDir1 f 
245     | (Path.dirname f) `Path.isBelow` "." = Just (Path.dirname f)
246     | otherwise = Nothing
247
248 --
249 -- filter rules by the set of architectures in Config.architectures
250 --
251 filterRuleByArch :: HRule -> Maybe HRule
252 filterRuleByArch (Rule toks) = if allowedArchs (map frArch toks) then Just (Rule toks) else Nothing
253 filterRuleByArch (Include tok) = if allowedArchs [frArch tok] then Just (Include tok) else Nothing
254 filterRuleByArch (Rules rules) = Just (Rules (catMaybes $ map filterRuleByArch rules))
255 filterRuleByArch x = Just x
256
257 -- a rule is included if it has only "special" architectures and enabled architectures
258 allowedArchs :: [String] -> Bool
259 allowedArchs = all (\a -> a `elem` (Config.architectures ++ specialArchitectures))
260     where specialArchitectures = ["", "src", "hake", "root", "tools", "docs"]
261
262 -- 
263 -- Functions to format rules as Makefile rules
264 --
265 makeMakefile :: [(String, HRule)] -> String
266 makeMakefile r = 
267   unlines $ intersperse "" [makeMakefileSection f rl | (f,rl) <- r]
268
269 makeMakefileSection :: String -> HRule -> String
270 makeMakefileSection fname rules = 
271     "# From: " ++ fname ++ "\n\n" ++ makeMakeRules rules
272
273 makeMakeRules :: HRule -> String
274 makeMakeRules (Rules hrules)
275     = unlines [ s | s <- [ makeMakeRules h | h <- hrules ], s /= "" ]
276 makeMakeRules (Include token) = unlines [
277     "ifeq ($(MAKECMDGOALS),clean)",
278     "else ifeq ($(MAKECMDGOALS),rehake)",
279     "else ifeq ($(MAKECMDGOALS),Makefile)",
280     "else",
281     "include " ++ (formatToken token),
282     "endif"]
283 makeMakeRules (Error s) = "$(error " ++ s ++ ")\n"
284 makeMakeRules (Rule tokens) = 
285     let outs = nub [ f | (Out a f) <- tokens ] ++ [ f | (Target a f) <- tokens ]
286         dirs = nub [ (Path.dirname f) ./. ".marker" | f <- outs ]
287         deps = nub [ f | (In t a f) <- tokens ] ++ [ f | (Dep t a f) <- tokens ] 
288         predeps = nub [ f | (PreDep t a f) <- tokens ] 
289         spaceSep :: [ String ] -> String
290         spaceSep sl = concat (intersperse " " sl)
291         ruleBody = (concat[ formatToken t | t <- tokens, inRule t ])
292     in if outs == [] then
293       ("# hake: omitted rule with no output: " ++ ruleBody)
294     else
295       (spaceSep outs) ++ ": " 
296       ++ 
297       -- It turns out that if you add 'dirs' here, in an attempt to
298       -- get Make to build the directories as well, it goes a bit
299       -- pear-shaped: whenever the directory "changes" it goes out of
300       -- date, so you end up rebuilding dependencies every time.
301       (spaceSep (deps ++ dirs)) 
302       ++ 
303       (if (predeps == []) then "" else " | " ++ spaceSep (predeps))
304       ++ "\n" 
305       ++
306       (if (ruleBody == "") then "" else "\t" ++ ruleBody ++ "\n")
307       
308
309 preamble :: Opts -> [String] -> String
310 preamble opts args = 
311     unlines ( [ "# This Makefile is generated by Hake.  Do not edit!",
312                 "# ",
313                 "# Hake was invoked with the following command line args:" ] ++
314               [ "#        " ++ a | a <- args ] ++
315               [ "# ",
316                 "SRCDIR=" ++ (opt_sourcedir opts),
317                 "HAKE_ARCHS=" ++ (concat $ intersperse " " Config.architectures),
318                 "include ./symbolic_targets.mk" ] )
319
320 stripSrcDir :: String -> String
321 stripSrcDir s = Path.removePrefix Config.source_dir s
322
323 hakeModule :: [String] -> [(String,String)] -> String
324 hakeModule allfiles hakefiles = 
325     let unqual_imports = ["RuleDefs", "HakeTypes", "Path", "Args"]
326         qual_imports = ["Config", "Data.List" ]
327         relfiles = [ stripSrcDir f | f <- allfiles ]
328         wrap1 n c = wrapLet "build a" 
329                     ("(buildFunction a) allfiles " ++ (show n) ++ " a")
330                     c
331         wrap n c = "(" ++ (show n) ++ ", " 
332                    ++ wrapLet "find fn arg" 
333                           ("(fn allfiles " ++ (show n) ++ " arg)") 
334                           ("Rules (" ++ (wrap1 n c) ++ ")")
335                    ++ ")"
336         flatten :: [String] -> String
337         flatten s = foldl (++) "" (intersperse ",\n" s)
338         addHeader (fn,fc) = (fn, "{-# LINE 1 \"" ++ fn ++ "\" #-}\n" ++ fc)
339         files = flatten [ wrap (stripSrcDir fn) fc | (fn,fc) <- map addHeader hakefiles ]
340     in
341       unlines ( [ "module Hakefiles where {" ]
342                 ++
343                 [ "import " ++ i ++ ";" | i <- unqual_imports ]
344                 ++
345                 [ "import qualified " ++ i ++ ";" | i <- qual_imports ] 
346                 ++
347                 [ "allfiles = " ++ (show relfiles) ++ ";" ]
348                 ++ 
349                 [ "hf = [" ] 
350               ) ++ files ++ "];\n}"
351
352 wrapLet :: String -> String -> String -> String
353 wrapLet var expr body = 
354     "(let " ++ var ++ " = " ++ expr ++ " in\n" ++ body ++ ")"
355
356 evalHakeFiles :: Opts -> [String] -> [(String,String)] 
357               -> IO [(String,HRule)]
358 evalHakeFiles o allfiles hakefiles = 
359     let imports = [ "Hakefiles"]
360         all_imports = imports
361         moddirs = [ (opt_installdir o) ./. "hake", 
362                     ".", 
363                     (opt_bfsourcedir o) ./. "hake" ]
364     in do 
365       defaultErrorHandler defaultLogAction $ do
366          runGhc (Just libdir) $ do
367            dflags <- getSessionDynFlags
368            let dflags1 = foldl xopt_set dflags [ Opt_DeriveDataTypeable ]
369            _ <- setSessionDynFlags dflags1{
370                 importPaths = moddirs,
371                 hiDir = Just "./hake",
372                 objectDir = Just "./hake"
373            }
374            targets <- mapM (\m -> guessTarget m Nothing) imports
375            setTargets targets
376            load LoadAllTargets
377            modlist <- mapM (\m -> findModule (mkModuleName m) Nothing) all_imports
378            setContext [IIModule m | m <- modlist]
379            val <- dynCompileExpr "Hakefiles.hf :: [(String, HRule)]" 
380            return (fromDyn val [("failed",Error "failed")])
381
382 --
383 -- Generate dependencies of the Makefile on all the Hakefiles
384 --
385 --resolveRelativePaths o (Rules hrules) root 
386 --- resolveRelativePath o (In t a f) root = 
387 makeHakeDeps :: Opts -> [ String ] -> String
388 makeHakeDeps o l = 
389     let hake = resolveRelativePath o (In InstallTree "root" "/hake/hake") ""
390         makefile = resolveRelativePath o (Out "root" (opt_makefilename o)) "/Hakefile"
391         rule = Rule ( [ hake, 
392                         Str "--source-dir", Str (opt_sourcedir o),
393                         Str "--install-dir", Str (opt_installdir o),
394                         Str "--output-filename", makefile
395                       ] ++
396                       [ Dep SrcTree "root" h | h <- l ]
397                     )
398     in
399      (makeMakeRules rule)
400      ++ ".DELETE_ON_ERROR:\n\n" -- this applies to all targets in the Makefile
401
402 makeHakeDeps1 :: Opts -> [ String ] -> String
403 makeHakeDeps1 _ l = 
404     "Makefile: ./hake/hake " 
405     ++ concat (intersperse " " l)
406     ++ "\n\t./hake/hake Makefile\n"
407     ++ ".DELETE_ON_ERROR:\n\n" -- this applies to all targets in the Makefile
408
409 -- check the configuration options, returning an error string if they're insane
410 configErrors :: Maybe String
411 configErrors
412     | unknownArchs /= [] = Just ("unknown architecture(s) specified: "
413                                ++ (concat $ intersperse ", " unknownArchs))
414     | Config.architectures == [] = Just "no architectures defined"
415     | Config.lazy_thc && not Config.use_fp = Just "Config.use_fp must be true to use Config.lazy_thc."
416     | otherwise = Nothing
417     where
418     unknownArchs = Config.architectures \\ Args.allArchitectures
419
420
421 ---
422 --- Convert a Hakefile name to one relative to the root of the source tree. 
423 ---
424 strip_hfn :: Opts -> String -> String
425 strip_hfn opts f = Path.removePrefix (opt_sourcedir opts) f
426
427 main :: IO() 
428 main = do
429     -- parse arguments; architectures default to config file
430     args <- System.Environment.getArgs
431     let o1 = parse_arguments args
432         al = if opt_architectures o1 == [] 
433              then Config.architectures 
434              else opt_architectures o1
435         opts = o1 { opt_architectures = al }
436     if opt_usage_error opts then do
437         hPutStrLn stderr usage
438         exitWith $ ExitFailure 1
439       else do
440
441     -- sanity-check configuration settings
442     -- this is currently known at compile time, but might not always be!
443     if isJust configErrors then do
444         hPutStrLn stderr $ "Error in configuration: " ++ (fromJust configErrors)
445         exitWith $ ExitFailure 2    
446       else do
447
448     hPutStrLn stdout ("Source directory: " ++ opt_sourcedir opts)
449     hPutStrLn stdout ("BF Source directory: " ++ opt_bfsourcedir opts)
450     hPutStrLn stdout ("Install directory: " ++ opt_installdir opts)
451
452     hPutStrLn stdout "Reading directory tree..."
453     l <- listFilesR (opt_sourcedir opts)
454     hPutStrLn stdout "Reading Hakefiles..."
455     hfl <- readHakeFiles $ hakeFiles l
456     hPutStrLn stdout "Writing HakeFile module..."
457     modf <- openFile ("Hakefiles.hs") WriteMode
458     hPutStrLn modf $ hakeModule l hfl
459     hClose modf
460     hPutStrLn stdout "Evaluating Hakefiles..."
461     inrules <- evalHakeFiles opts l hfl
462     hPutStrLn stdout "Done!"
463     -- filter out rules for unsupported architectures and resolve relative paths
464     let rules = 
465           ([(f, resolveRelativePaths opts (fromJust (filterRuleByArch rl)) (strip_hfn opts f))
466            | (f,rl) <- inrules, isJust (filterRuleByArch rl) ])
467     hPutStrLn stdout $ "Generating " ++ (opt_makefilename opts) ++ " - this may take some time (and RAM)..." 
468     makef <- openFile(opt_makefilename opts) WriteMode
469     hPutStrLn makef $ preamble opts args
470     -- let hfl2 = [ strip_hfn opts (fst h) | h <- hfl ]
471     hPutStrLn makef $ makeHakeDeps opts $ map fst hfl
472     hPutStrLn makef $ makeMakefile rules
473     hPutStrLn makef $ makeDirectories rules
474     hClose makef
475     exitWith ExitSuccess