5575344a7cde51e88128826cf28e828987c45106
[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 -> [FilePath] -> (String, [String] -> HRule) -> IO ()
272 makefileSection h allfiles (hake_name, rule_schema) = do
273     hPutStrLn h $ "# From: " ++ hake_name ++ "\n"
274     makefileRule h (rule_schema allfiles)
275
276 makefileRule :: Handle -> HRule -> IO ()
277 makefileRule h (Error s) =
278     hPutStr h $ "$(error " ++ s ++ ")"
279 makefileRule h (Rules rules) =
280     mapM_ (makefileRule h) rules
281 makefileRule h (Include token) =
282     when (allowedArchs [frArch token]) $
283         mapM_ (hPutStr h) [
284             "ifeq ($(MAKECMDGOALS),clean)",
285             "else ifeq ($(MAKECMDGOALS),rehake)",
286             "else ifeq ($(MAKECMDGOALS),Makefile)",
287             "else",
288             "include " ++ (formatToken token),
289             "endif" ]
290 makefileRule h (HakeTypes.Rule tokens) =
291     when (allowedArchs (map frArch tokens)) $
292         makefileRuleInner h tokens False
293 makefileRule h (Phony name double_colon tokens) = do
294     hPutStrLn h $ ".PHONY: " ++ name
295     makefileRuleInner h (Target "build" name : tokens) double_colon
296
297 printTokens :: Handle -> S.Set RuleToken -> IO ()
298 printTokens h tokens =
299     S.foldr (\t m -> hPutStr h (formatToken t) >> m) (return ()) tokens
300
301 makefileRuleInner :: Handle -> [RuleToken] -> Bool -> IO ()
302 makefileRuleInner h tokens double_colon = do
303     if S.null (ruleOutputs compiledRule)
304     then do
305         hPutStr h "# hake: omitted rule with no output: "
306         doBody
307     else do
308         printTokens h $ ruleOutputs compiledRule
309         if double_colon then hPutStr h ":: " else hPutStr h ": "
310         printTokens h $ ruleDepends compiledRule
311         printTokens h $ ruleDirs compiledRule
312         when (not (S.null (rulePreDepends compiledRule))) $ do
313             hPutStr h " | "
314             printTokens h $ rulePreDepends compiledRule
315         hPutStrLn h ""
316         doBody
317     where
318         compiledRule = compileRule tokens
319
320         doBody :: IO ()
321         doBody =
322             when (ruleBody compiledRule /= []) $ do
323                 hPutStr h "\t"
324                 mapM_ (hPutStr h . formatToken) $ ruleBody compiledRule
325                 hPutStrLn h ""
326
327 scanTokens :: [RuleToken] -> (S.Set RuleToken, S.Set RuleToken,
328                               S.Set RuleToken, [RuleToken],
329                               S.Set RuleToken)
330 scanTokens [] = (S.empty, S.empty, S.empty, [], S.empty)
331 scanTokens (t:ts) =
332     case t of
333         Out _ f      -> (S.insert t outs, deps, predeps, body',
334                          S.insert (dirOf f) dirs)
335         Target _ f   -> (S.insert t outs, deps, predeps, body',
336                          S.insert (dirOf f) dirs)
337         In _ _ _     -> (outs, S.insert t deps, predeps, body', dirs)
338         Dep _ _ _    -> (outs, S.insert t deps, predeps, body', dirs)
339         PreDep _ _ _ -> (outs, deps, S.insert t predeps, body', dirs)
340         _            -> (outs, deps, predeps, body', dirs)
341     where
342         (outs, deps, predeps, body, dirs) = scanTokens ts
343         body' = if inRule t then t:body else body
344
345         dirOf :: FilePath -> RuleToken
346         dirOf f = Str $ (takeDirectory f) </> ".marker"
347
348 data CompiledRule =
349     CompiledRule {
350         ruleOutputs    :: S.Set RuleToken,
351         ruleDepends    :: S.Set RuleToken,
352         rulePreDepends :: S.Set RuleToken,
353         ruleBody       :: [RuleToken],
354         ruleDirs       :: S.Set RuleToken
355     }
356
357 compileRule :: [RuleToken] -> CompiledRule
358 compileRule tokens
359     = CompiledRule {
360         ruleOutputs    = outs,
361         ruleDepends    = deps,
362         rulePreDepends = predeps,
363         ruleBody       = body,
364         ruleDirs       = dirs
365         }
366     where
367         (outs, deps, predeps, body, dirs) = scanTokens tokens
368
369 gcStats :: IO ()
370 gcStats = do
371     performGC
372     gc_stats <- getGCStats
373     putStrLn $ show (currentBytesUsed gc_stats) ++ " - " ++
374                show (numGcs gc_stats) ++ " - " ++
375                show (maxBytesUsed gc_stats) ++ " - " ++
376                show (wallSeconds gc_stats)
377
378 body :: HakeMonad ()
379 body =  do
380     -- parse arguments; architectures default to config file
381     args <- liftIO $ System.Environment.getArgs
382     let o1 = parse_arguments args
383         al = if opt_architectures o1 == [] 
384              then Config.architectures 
385              else opt_architectures o1
386         opts = o1 { opt_architectures = al }
387
388     when (opt_usage_error opts) $
389         throwError (HakeError usage 1)
390
391     -- sanity-check configuration settings
392     -- this is currently known at compile time, but might not always be!
393     when (isJust configErrors) $
394         throwError (HakeError ("Error in configuration: " ++
395                                (fromJust configErrors)) 2)
396
397     liftIO $ putStrLn ("Source directory: " ++ opt_sourcedir opts)
398     liftIO $ putStrLn ("BF Source directory: " ++ opt_bfsourcedir opts)
399     liftIO $ putStrLn ("Install directory: " ++ opt_installdir opts)
400
401     liftIO gcStats
402
403     liftIO $ putStrLn "Reading directory tree..."
404     (allfiles, hakefiles) <- liftIO $ listFiles (opt_sourcedir opts)
405
406     liftIO gcStats
407
408     rules <- liftIO $ evalHakeFiles opts hakefiles
409     liftIO $ putStrLn $ show (length rules)
410
411     liftIO gcStats
412
413     liftIO $ putStrLn $ "Generating " ++ (opt_makefilename opts)
414     makefile <- liftIO $ openFile(opt_makefilename opts) WriteMode
415     liftIO $ makefilePreamble makefile opts args
416     liftIO $ mapM_ (makefileSection makefile allfiles) rules
417
418     liftIO gcStats
419
420     return ()
421
422 main :: IO () 
423 main = do
424     r <- runErrorT $ body `catchError` handleFailure
425     exitWith ExitSuccess
426     where
427         handleFailure (HakeError str n) = do
428             liftIO $ putStrLn str
429             liftIO $ exitWith (ExitFailure n)