Replaced old hake
authorDavid Cock <david.cock@inf.ethz.ch>
Tue, 18 Aug 2015 07:24:19 +0000 (09:24 +0200)
committerDavid Cock <david.cock@inf.ethz.ch>
Tue, 18 Aug 2015 07:24:19 +0000 (09:24 +0200)
Signed-off-by: David Cock <david.cock@inf.ethz.ch>

hake/Hake2.hs [deleted file]
hake/Hakefile
hake/Main.hs
hake/hake.sh

diff --git a/hake/Hake2.hs b/hake/Hake2.hs
deleted file mode 100644 (file)
index 89aaf1f..0000000
+++ /dev/null
@@ -1,553 +0,0 @@
-import Control.Monad.Error
-
-import Data.Dynamic
-import Data.List
-import Data.Maybe
-import qualified Data.Set as S
-
-import System.Directory
-import System.Environment
-import System.Exit
-import System.FilePath
-import System.IO
-import System.Mem
-
-import GHC hiding (Target, Ghc, GhcT, runGhc, runGhcT, FunBind, Match)
-import GHC.Paths (libdir)
-import Control.Monad.Ghc
-import DynFlags (defaultFatalMessager, defaultFlushOut,
-                 xopt_set, ExtensionFlag (Opt_DeriveDataTypeable))
-import GHC.Stats
-
-import Language.Haskell.Exts
-
-import RuleDefs
-import HakeTypes
-import qualified Args
-import qualified Config
-import qualified Path
-
-data HakeError = HakeError String Int
-instance Error HakeError
-type HakeMonad = ErrorT HakeError IO
-
---
--- Command line options and parsing code
---
-data Opts = Opts { opt_makefilename :: String,
-                   opt_installdir :: String,
-                   opt_sourcedir :: String,
-                   opt_bfsourcedir :: String,
-                   opt_usage_error :: Bool,
-                   opt_architectures :: [String],
-                   opt_verbosity :: Integer
-                 }
-          deriving (Show,Eq)
-                   
-parse_arguments :: [String] -> Opts
-parse_arguments [] =
-  Opts { opt_makefilename = "Makefile",
-         opt_installdir = Config.install_dir,
-         opt_sourcedir = Config.source_dir,
-         opt_bfsourcedir = Config.source_dir,
-         opt_usage_error = False, 
-         opt_architectures = [],
-         opt_verbosity = 1 }
-parse_arguments ("--install-dir" : (s : t)) =
-  (parse_arguments t) { opt_installdir = s }
-parse_arguments ("--source-dir" : s : t) =  
-  (parse_arguments t) { opt_sourcedir = s }
-parse_arguments ("--bfsource-dir" : s : t) =  
-  (parse_arguments t) { opt_bfsourcedir = s }
-parse_arguments ("--output-filename" : s : t) =
-  (parse_arguments t) { opt_makefilename = s }
-parse_arguments ("--quiet" : t ) = 
-  (parse_arguments t) { opt_verbosity = 0 }
-parse_arguments ("--verbose" : t ) = 
-  (parse_arguments t) { opt_verbosity = 2 }
-parse_arguments ("--architecture" : a : t ) = 
-  let 
-    o2 = parse_arguments t
-    arches = (a : opt_architectures o2)
-  in
-    o2 { opt_architectures = arches }
-parse_arguments _ = 
-  (parse_arguments []) { opt_usage_error = True }
-
-usage :: String
-usage = unlines [ "Usage: hake <options>",
-                  "   --source-dir <dir> (required)",
-                  "   --bfsource-dir <dir> (defaults to source dir)",
-                  "   --install-dir <dir> (defaults to source dir)",
-                  "   --quiet",
-                  "   --verbose"
-                ]
-
--- check the configuration options, returning an error string if they're insane
-configErrors :: Maybe String
-configErrors
-    | unknownArchs /= [] =
-        Just ("unknown architecture(s) specified: " ++
-        (concat $ intersperse ", " unknownArchs))
-    | Config.architectures == [] =
-        Just "no architectures defined"
-    | Config.lazy_thc && not Config.use_fp =
-        Just "Config.use_fp must be true to use Config.lazy_thc."
-    | otherwise =
-        Nothing
-    where
-        unknownArchs = Config.architectures \\ Args.allArchitectures
-
---
--- Walk all over a directory tree and build a complete list of pathnames
---
-listFiles :: FilePath -> IO ([FilePath], [(FilePath, String)])
-listFiles root = do
-    isdir <- doesDirectoryExist root
-    if isdir then do
-        children <- getDirectoryContents root
-        walkchildren children
-    else
-        return ([], [])
-    where
-        walkchildren :: [FilePath] -> IO ([FilePath], [(FilePath, String)])
-        walkchildren [] = return ([], [])
-        walkchildren (child:siblings) = do
-            (allfiles, hakefiles) <- walkchild child
-            (allfilesS, hakefilesS) <- walkchildren siblings
-            return $ (allfiles ++ allfilesS, hakefiles ++ hakefilesS)
-
-        walkchild :: FilePath -> IO ([FilePath], [(FilePath, String)])
-        walkchild child = do
-            if ignore child
-            then return ([], [])
-            else do
-                (allfiles, hakefiles) <- listFiles (root </> child)
-                hake <- maybeHake child
-                return $ ((root </> child) : allfiles,
-                          hake ++ hakefiles)
-            where
-                maybeHake "Hakefile" = do
-                    contents <- readFile (root </> child)
-                    return [(root </> child, contents)]
-                maybeHake _ = return []
-
-        ignore :: FilePath -> Bool
-        ignore "."          = True
-        ignore ".."         = True
-        ignore "CMakeFiles" = True
-        ignore ".hg"        = True
-        ignore "build"      = True
-        ignore ".git"       = True
-        ignore _            = False
-
-instance Show SuccessFlag
-instance Show RunResult
-
-driveGhc :: Opts -> [(FilePath, String)] -> Ghc ([(String, [String] -> HRule)])
-driveGhc o hakefiles = do
-    -- Set the RTS flags
-    dflags <- getSessionDynFlags
-    let dflags' = foldl xopt_set dflags [ Opt_DeriveDataTypeable ]
-    _ <- setSessionDynFlags dflags'{
-        importPaths = module_paths,
-        hiDir = Just "./hake",
-        objectDir = Just "./hake"
-    }
-
-    -- Set compilation targets
-    targets <- mapM (\m -> guessTarget m Nothing) source_modules
-    setTargets targets
-    load LoadAllTargets
-
-    -- Import modules
-    setContext
-        ([IIDecl $ simpleImportDecl $ mkModuleName m |
-            m <- modules] ++
-         [IIDecl $ (simpleImportDecl $ mkModuleName m) {
-                ideclQualified = True
-          } | m <- qualified_modules])
-
-    mapM evaluate hakefiles
-
-    where
-        module_paths = [ (opt_installdir o) </> "hake", ".", 
-                         (opt_bfsourcedir o) </> "hake" ]
-        source_modules = [ "HakeTypes", "RuleDefs", "Path", "Args", "Config" ]
-        modules = [ "Prelude", "HakeTypes", "RuleDefs", "Path", "Args" ]
-        qualified_modules = [ "Config", "Data.List" ]
-
-        evaluate :: (FilePath, String) -> Ghc ((String, [String] -> HRule))
-        evaluate (hake_name, hake_raw) = do
-            case hake_parse of
-                Left hake_expr -> do
-                    let hake_wrapped =
-                            prettyPrintWithMode (defaultMode {layout = PPNoLayout}) $
-                                wrapHake hake_name hake_expr
-
-                    val <- dynCompileExpr $ hake_wrapped ++ " :: [String] -> HRule"
-                    liftIO $ putStrLn ( "Success: " ++ hake_name )
-                    return $ (hake_name, fromDyn val (\_ -> Error "failed"))
-                Right hake_error -> do
-                    return $ (hake_name, \_ -> Error "failed")
-            where
-                hake_parse = parseHake (hake_name, hake_raw)
-
-evalHakeFiles :: Opts -> [(FilePath, String)] ->
-                 IO ([(String, [String] -> HRule)])
-evalHakeFiles o hakefiles =
-    defaultErrorHandler defaultFatalMessager defaultFlushOut $
-        runGhc (Just libdir) $
-        driveGhc o hakefiles
-
-parseHake :: (FilePath, String) -> Either Exp HakeError
-parseHake (filename, contents) =
-    case result of
-        ParseOk e -> Left e
-        ParseFailed loc str ->
-            Right $ HakeError (show loc ++ ": " ++ str) 2
-    where
-        result =
-            parseExpWithMode
-                (defaultParseMode {
-                    parseFilename = filename,
-                    baseLanguage = Haskell2010 })
-                contents
-
-wrapHake :: FilePath -> Exp -> Exp
-wrapHake hakefile hake_exp =
-    Paren (
-    Lambda dummy_loc [PVar (Ident "allfiles")] (
-    Let (BDecls
-        [FunBind [Match
-            dummy_loc
-            (Ident "find")
-            [PVar (Ident "fn"), PVar (Ident "arg")]
-            Nothing
-            (UnGuardedRhs
-                (Paren (App (App (App (Var (UnQual (Ident "fn")))
-                                      (Var (UnQual (Ident "allfiles"))))
-                                 (Lit (String hakefile)))
-                       (Var (UnQual (Ident "arg"))))))
-            (BDecls [])],
-
-        FunBind [Match
-            dummy_loc
-            (Ident "build")
-            [PVar (Ident "a")]
-            Nothing
-            (UnGuardedRhs
-                (App (App (App (Paren (App (Var (UnQual (Ident "buildFunction")))
-                                           (Var (UnQual (Ident "a")))))
-                               (Var (UnQual (Ident "allfiles"))))
-                          (Lit (String hakefile)))
-                     (Var (UnQual (Ident "a")))))
-            (BDecls [])]
-        ])
-        (Paren (App (Con (UnQual (Ident "Rules")))
-                    hake_exp))
-    ))
-    where
-        dummy_loc = SrcLoc { srcFilename = "<hake internal>",
-                                srcLine = 0, srcColumn = 0 }
-
-makefilePreamble :: Handle -> Opts -> [String] -> IO ()
-makefilePreamble h opts args = 
-    mapM_ (hPutStrLn h)
-          ([ "# This Makefile is generated by Hake.  Do not edit!",
-             "# ",
-             "# Hake was invoked with the following command line args:" ] ++
-           [ "#        " ++ a | a <- args ] ++
-           [ "# ",
-             "SRCDIR=" ++ (opt_sourcedir opts),
-             "HAKE_ARCHS=" ++ (concat $ intersperse " " Config.architectures),
-             "include ./symbolic_targets.mk" ])
-
--- a rule is included if it has only "special" architectures and enabled architectures
-allowedArchs :: [String] -> Bool
-allowedArchs = all (\a -> a `elem` (Config.architectures ++ specialArchitectures))
-    where specialArchitectures = ["", "src", "hake", "root", "tools", "docs"]
-
-makefileSection :: Handle -> Opts -> [FilePath] ->
-                   (String, [String] -> HRule) -> IO (S.Set FilePath)
-makefileSection h opts allfiles (hake_name, rule_schema) = do
-    hPutStrLn h $ "# From: " ++ hake_name ++ "\n"
-    makefileRule h $
-        resolveRelativePaths opts (rule_schema allfiles) hake_name
-
-makefileRule :: Handle -> HRule -> IO (S.Set FilePath)
-makefileRule h (Error s) = do
-    hPutStrLn h $ "$(error " ++ s ++ ")\n"
-    return S.empty
-makefileRule h (Rules rules) = do
-    dir_lists <- mapM (makefileRule h) rules
-    return $ S.unions dir_lists
-makefileRule h (Include token) = do
-    when (allowedArchs [frArch token]) $
-        mapM_ (hPutStrLn h) [
-            "ifeq ($(MAKECMDGOALS),clean)",
-            "else ifeq ($(MAKECMDGOALS),rehake)",
-            "else ifeq ($(MAKECMDGOALS),Makefile)",
-            "else",
-            "include " ++ (formatToken token),
-            "endif",
-            "" ]
-    return S.empty
-makefileRule h (HakeTypes.Rule tokens) =
-    if allowedArchs (map frArch tokens)
-        then makefileRuleInner h tokens False
-        else return S.empty
-makefileRule h (Phony name double_colon tokens) = do
-    hPutStrLn h $ ".PHONY: " ++ name
-    makefileRuleInner h (Target "build" name : tokens) double_colon
-
-printTokens :: Handle -> S.Set RuleToken -> IO ()
-printTokens h tokens =
-    S.foldr (\t m -> hPutStr h (formatToken t) >> m) (return ()) tokens
-
-printDirs :: Handle -> S.Set FilePath -> IO ()
-printDirs h dirs =
-    S.foldr (\d m -> hPutStr h (d ++ " ") >> m) (return ()) dirs
-
-makefileRuleInner :: Handle -> [RuleToken] -> Bool -> IO (S.Set FilePath)
-makefileRuleInner h tokens double_colon = do
-    if S.null (ruleOutputs compiledRule)
-    then do
-        hPutStr h "# hake: omitted rule with no output: "
-        doBody
-    else do
-        printTokens h $ ruleOutputs compiledRule
-        if double_colon then hPutStr h ":: " else hPutStr h ": "
-        printTokens h $ ruleDepends compiledRule
-        printDirs h $ ruleDirs compiledRule
-        when (not (S.null (rulePreDepends compiledRule))) $ do
-            hPutStr h " | "
-            printTokens h $ rulePreDepends compiledRule
-        hPutStrLn h ""
-        doBody
-    where
-        compiledRule = compileRule tokens
-
-        doBody :: IO (S.Set FilePath)
-        doBody = do
-            when (ruleBody compiledRule /= []) $ do
-                hPutStr h "\t"
-                mapM_ (hPutStr h . formatToken) $ ruleBody compiledRule
-            hPutStrLn h "\n"
-            return $ ruleDirs compiledRule
-
----
---- Functions to resolve relative path names in rules. 
----
---- First, the outer function: resolve path names in an HRule. The
---- third argument, 'root', is frequently the pathname of the Hakefile
---- relative to the source tree - since relative pathnames in
---- Hakefiles are interpreted relative to the Hakefile location.
----
-resolveRelativePaths :: Opts -> HRule -> String -> HRule
-resolveRelativePaths o (Rules hrules) root 
-    = Rules [ resolveRelativePaths o r root | r <- hrules ]
-resolveRelativePaths o (HakeTypes.Rule tokens) root
-    = HakeTypes.Rule [ resolveRelativePath o t root | t <- tokens ]
-resolveRelativePaths o (Include token) root
-    = Include ( resolveRelativePath o token root )
-resolveRelativePaths o (Error s) root 
-    = Error s
-resolveRelativePaths o (Phony name dbl tokens) root 
-    = Phony name dbl [ resolveRelativePath o t root | t <- tokens ]
-
---- Now resolve at the level of individual rule tokens.  At this
---- level, we need to take into account the tree (source, build, or
---- install).
-resolveRelativePath :: Opts -> RuleToken -> String -> RuleToken
-resolveRelativePath o (In t a f) root = 
-    (In t a (resolveRelativePathName o t a f root))
-resolveRelativePath o (Out a f) root = 
-    (Out a (resolveRelativePathName o BuildTree a f root))
-resolveRelativePath o (Dep t a f) root = 
-    (Dep t a (resolveRelativePathName o t a f root))
-resolveRelativePath o (NoDep t a f) root = 
-    (NoDep t a (resolveRelativePathName o t a f root))
-resolveRelativePath o (PreDep t a f) root = 
-    (PreDep t a (resolveRelativePathName o t a f root))
-resolveRelativePath o (Target a f) root = 
-    (Target a (resolveRelativePathName o BuildTree a f root))
-resolveRelativePath _ (Str s) _ = (Str s)
-resolveRelativePath _ (NStr s) _ = (NStr s)
-resolveRelativePath _ (ErrorMsg s) _ = (ErrorMsg s)
-resolveRelativePath _ NL _ = NL
-
---- Now we get down to the nitty gritty.  We have, in order:
----   o: The options in force.
----   t: The tree (source, build, or install)
----   a: The architecture (e.g. armv7)
----   p: The pathname we want to resolve to a full path, and
----   h: The dirname of the Hakefile in which it occurs.
---- If the tree is SrcTree or the architecture is "root", everything
---- is relative to the top-level directory for that tree.  Otherwise,
---- it's relative to the top-level directory plus the architecture.
-resolveRelativePathName :: Opts -> TreeRef -> String -> String -> String -> String
-
-resolveRelativePathName o SrcTree "root" f h = 
-    resolveRelativePathName' ((opt_sourcedir o)) f h
-resolveRelativePathName o BuildTree "root" f h = 
-    resolveRelativePathName' "." f h
-resolveRelativePathName o InstallTree "root" f h = 
-    resolveRelativePathName' ((opt_installdir o)) f h
-
-resolveRelativePathName o SrcTree a f h =
-    resolveRelativePathName' (opt_sourcedir o) f h
-resolveRelativePathName o BuildTree a f h =
-    resolveRelativePathName' ("." </> a) f h
-resolveRelativePathName o InstallTree a f h =
-    resolveRelativePathName' ((opt_installdir o) </> a) f h
-
---- This is where the work is done: take 'hd' (pathname relative to
---- us of the Hakefile) and resolve the filename we're interested in
---- relative to this.  This gives us a pathname relative to some root
---- of some architecture tree, then return this relative to the actual
---- tree we're interested in.  It's troubling that this takes more
---- bytes to explain than to code.
----   d:    Pathname of top directory of the tree (source, build, install)
----   f:    Filename we are interested in, relative to 'root' below
----   hd:   Directory containing the Hakefile
----   
-resolveRelativePathName' d f hd = 
-    let af = Path.relToFile f hd
-        rf = Path.makeRel $ Path.relToDir af "/" 
-    in Path.relToDir rf d
-
-makeHakeDeps :: Handle -> Opts -> [String] -> IO ()
-makeHakeDeps h o l = do
-    makefileRule h rule
-    hPutStrLn h ".DELETE_ON_ERROR:\n" -- this applies to all targets in the Makefile
-    where
-        hake = resolveRelativePath o (In InstallTree "root" "/hake/hake") ""
-        makefile = resolveRelativePath o (Out "root" (opt_makefilename o)) "/Hakefile"
-        rule = HakeTypes.Rule
-                    ( [ hake, 
-                        Str "--source-dir", Str (opt_sourcedir o),
-                        Str "--install-dir", Str (opt_installdir o),
-                        Str "--output-filename", makefile
-                      ] ++
-                      [ Dep SrcTree "root" h | h <- l ]
-                    )
-
-makeDirectories :: Handle -> S.Set FilePath -> IO ()
-makeDirectories h dirs = do
-    hPutStrLn h "# Directories follow"
-    mapM_ (makeDir h) (S.toList (S.delete ("." </> ".marker") dirs))
-
-makeDir :: Handle -> FilePath -> IO ()
-makeDir h dir = do
-    hPutStrLn h $ "hake_dirs: " ++ dir ++ "\n"
-    hPutStrLn h $ dir ++ ":"
-    hPutStrLn h $ "\tmkdir -p " ++ (takeDirectory dir)
-    hPutStrLn h $ "\ttouch " ++ dir
-    hPutStrLn h ""
-
-scanTokens :: [RuleToken] -> (S.Set RuleToken, S.Set RuleToken,
-                              S.Set RuleToken, [RuleToken],
-                              S.Set FilePath)
-scanTokens [] = (S.empty, S.empty, S.empty, [], S.empty)
-scanTokens (t:ts) =
-    case t of
-        Out _ f      -> (S.insert t outs, deps, predeps, body',
-                         S.insert (dirOf f) dirs)
-        Target _ f   -> (S.insert t outs, deps, predeps, body',
-                         S.insert (dirOf f) dirs)
-        In _ _ _     -> (outs, S.insert t deps, predeps, body', dirs)
-        Dep _ _ _    -> (outs, S.insert t deps, predeps, body', dirs)
-        PreDep _ _ _ -> (outs, deps, S.insert t predeps, body', dirs)
-        _            -> (outs, deps, predeps, body', dirs)
-    where
-        (outs, deps, predeps, body, dirs) = scanTokens ts
-        body' = if inRule t then t:body else body
-
-        dirOf :: FilePath -> FilePath
-        dirOf f = (takeDirectory f) </> ".marker"
-
-data CompiledRule =
-    CompiledRule {
-        ruleOutputs    :: S.Set RuleToken,
-        ruleDepends    :: S.Set RuleToken,
-        rulePreDepends :: S.Set RuleToken,
-        ruleBody       :: [RuleToken],
-        ruleDirs       :: S.Set FilePath
-    }
-
-compileRule :: [RuleToken] -> CompiledRule
-compileRule tokens
-    = CompiledRule {
-        ruleOutputs    = outs,
-        ruleDepends    = deps,
-        rulePreDepends = predeps,
-        ruleBody       = body,
-        ruleDirs       = dirs
-        }
-    where
-        (outs, deps, predeps, body, dirs) = scanTokens tokens
-
-gcStats :: IO ()
-gcStats = do
-    performGC
-    gc_stats <- getGCStats
-    putStrLn $ show (currentBytesUsed gc_stats) ++ " - " ++
-               show (numGcs gc_stats) ++ " - " ++
-               show (maxBytesUsed gc_stats) ++ " - " ++
-               show (wallSeconds gc_stats)
-
-body :: HakeMonad ()
-body =  do
-    -- parse arguments; architectures default to config file
-    args <- liftIO $ System.Environment.getArgs
-    let o1 = parse_arguments args
-        al = if opt_architectures o1 == [] 
-             then Config.architectures 
-             else opt_architectures o1
-        opts = o1 { opt_architectures = al }
-
-    when (opt_usage_error opts) $
-        throwError (HakeError usage 1)
-
-    -- sanity-check configuration settings
-    -- this is currently known at compile time, but might not always be!
-    when (isJust configErrors) $
-        throwError (HakeError ("Error in configuration: " ++
-                               (fromJust configErrors)) 2)
-
-    liftIO $ putStrLn ("Source directory: " ++ opt_sourcedir opts)
-    liftIO $ putStrLn ("BF Source directory: " ++ opt_bfsourcedir opts)
-    liftIO $ putStrLn ("Install directory: " ++ opt_installdir opts)
-
-    liftIO gcStats
-
-    liftIO $ putStrLn "Reading directory tree..."
-    (allfiles, hakefiles) <- liftIO $ listFiles (opt_sourcedir opts)
-
-    liftIO gcStats
-
-    rules <- liftIO $ evalHakeFiles opts hakefiles
-    liftIO $ putStrLn $ show (length rules)
-
-    liftIO gcStats
-
-    liftIO $ putStrLn $ "Generating " ++ (opt_makefilename opts)
-    makefile <- liftIO $ openFile(opt_makefilename opts) WriteMode
-    liftIO $ makefilePreamble makefile opts args
-    liftIO $ makeHakeDeps makefile opts $ map fst hakefiles
-    dirs <- liftIO $ mapM (makefileSection makefile opts allfiles) rules
-    liftIO $ makeDirectories makefile (S.unions dirs)
-
-    liftIO gcStats
-
-    return ()
-
-main :: IO () 
-main = do
-    r <- runErrorT $ body `catchError` handleFailure
-    exitWith ExitSuccess
-    where
-        handleFailure (HakeError str n) = do
-            liftIO $ putStrLn str
-            liftIO $ exitWith (ExitFailure n)
index a0d8897..b118019 100644 (file)
@@ -25,8 +25,7 @@ in
           Str "-outputdir", NoDep BuildTree "hake" "/",
           NStr "-i", NoDep SrcTree "src" "",
           NStr "-i", NoDep BuildTree "hake" "/",
-          --In SrcTree "src" "Main.hs",
-          In SrcTree "src" "Hake2.hs",
+          In SrcTree "src" "Main.hs",
           Dep InstallTree "" "Config.hs",
           Str "$(LDFLAGS)"
         ] 
index e301ff4..9626f79 100644 (file)
@@ -1,37 +1,35 @@
-{- 
-  Hake: a meta build system for Barrelfish
+import Control.Monad.Error
 
-  Copyright (c) 2009, ETH Zurich.
-  All rights reserved.
-  
-  This file is distributed under the terms in the attached LICENSE file.
-  If you do not find this file, copies can be found by writing to:
-  ETH Zurich D-INFK, Universit√§tstasse 6, CH-8092 Zurich. Attn: Systems Group.
--}
-  
-
-
-module Main where
+import Data.Dynamic
+import Data.List
+import Data.Maybe
+import qualified Data.Set as S
 
-import System.Environment
-import System.IO
 import System.Directory
+import System.Environment
 import System.Exit
-import GHC hiding (Target)
-import GHC.Paths ( libdir )
-import DynFlags ( defaultFatalMessager, defaultFlushOut,
-                  xopt_set,
-                  ExtensionFlag (Opt_DeriveDataTypeable) )
-import Data.Dynamic
-import Data.Maybe
-import Data.List
-import Control.Monad
+import System.FilePath
+import System.IO
+import System.Mem
+
+import GHC hiding (Target, Ghc, GhcT, runGhc, runGhcT, FunBind, Match)
+import GHC.Paths (libdir)
+import Control.Monad.Ghc
+import DynFlags (defaultFatalMessager, defaultFlushOut,
+                 xopt_set, ExtensionFlag (Opt_DeriveDataTypeable))
+import GHC.Stats
+
+import Language.Haskell.Exts
 
 import RuleDefs
 import HakeTypes
-import qualified Path
 import qualified Args
 import qualified Config
+import qualified Path
+
+data HakeError = HakeError String Int
+instance Error HakeError
+type HakeMonad = ErrorT HakeError IO
 
 --
 -- Command line options and parsing code
@@ -85,58 +83,261 @@ usage = unlines [ "Usage: hake <options>",
                   "   --verbose"
                 ]
 
---
--- Handy path operator
---
-infix 4 ./.
-root ./. path = Path.relToDir path root
-
+-- check the configuration options, returning an error string if they're insane
+configErrors :: Maybe String
+configErrors
+    | unknownArchs /= [] =
+        Just ("unknown architecture(s) specified: " ++
+        (concat $ intersperse ", " unknownArchs))
+    | Config.architectures == [] =
+        Just "no architectures defined"
+    | Config.lazy_thc && not Config.use_fp =
+        Just "Config.use_fp must be true to use Config.lazy_thc."
+    | otherwise =
+        Nothing
+    where
+        unknownArchs = Config.architectures \\ Args.allArchitectures
 
 --
 -- Walk all over a directory tree and build a complete list of pathnames
 --
-listFilesR :: FilePath -> IO [FilePath]
-listFilesR path = let
-    isDODD :: String -> Bool
-    isDODD f = not $ (isSuffixOf "/." f) 
-                  || (isSuffixOf "/.." f) 
-                  || (isSuffixOf "CMakeFiles" f)
-                  || (isPrefixOf (path ++ "/.hg") f)
-                  || (isPrefixOf (path ++ "/build") f)
-                  || (isPrefixOf (path ++ "/.git") f)
-
-    listDirs :: [FilePath] -> IO [FilePath]
-    listDirs = filterM doesDirectoryExist 
-
-    listFiles :: [FilePath] -> IO [FilePath]
-    listFiles = filterM doesFileExist
-
-    joinFN :: String -> String -> FilePath
-    -- joinFN p1 p2 = joinPath [p1, p2]
-    joinFN p1 p2 =  p1 ++ "/" ++ p2
-
-    in do
-        allfiles <- getDirectoryContents path
-        no_dots <- filterM (return . isDODD) (map (joinFN path) allfiles)
-        dirs <- listDirs no_dots
-        subdirfiles <- (mapM listFilesR dirs >>= return . concat)
-        files <- listFiles no_dots
-        return $ files ++ subdirfiles
+listFiles :: FilePath -> IO ([FilePath], [(FilePath, String)])
+listFiles root = do
+    isdir <- doesDirectoryExist root
+    if isdir then do
+        children <- getDirectoryContents root
+        walkchildren children
+    else
+        return ([], [])
+    where
+        walkchildren :: [FilePath] -> IO ([FilePath], [(FilePath, String)])
+        walkchildren [] = return ([], [])
+        walkchildren (child:siblings) = do
+            (allfiles, hakefiles) <- walkchild child
+            (allfilesS, hakefilesS) <- walkchildren siblings
+            return $ (allfiles ++ allfilesS, hakefiles ++ hakefilesS)
+
+        walkchild :: FilePath -> IO ([FilePath], [(FilePath, String)])
+        walkchild child = do
+            if ignore child
+            then return ([], [])
+            else do
+                (allfiles, hakefiles) <- listFiles (root </> child)
+                hake <- maybeHake child
+                return $ ((root </> child) : allfiles,
+                          hake ++ hakefiles)
+            where
+                maybeHake "Hakefile" = do
+                    contents <- readFile (root </> child)
+                    return [(root </> child, contents)]
+                maybeHake _ = return []
+
+        ignore :: FilePath -> Bool
+        ignore "."          = True
+        ignore ".."         = True
+        ignore "CMakeFiles" = True
+        ignore ".hg"        = True
+        ignore "build"      = True
+        ignore ".git"       = True
+        ignore _            = False
+
+instance Show SuccessFlag
+instance Show RunResult
+
+driveGhc :: Opts -> [FilePath] -> [(FilePath, String)] ->
+            Ghc ([(String, HRule)])
+driveGhc o allfiles hakefiles = do
+    -- Set the RTS flags
+    dflags <- getSessionDynFlags
+    let dflags' = foldl xopt_set dflags [ Opt_DeriveDataTypeable ]
+    _ <- setSessionDynFlags dflags'{
+        importPaths = module_paths,
+        hiDir = Just "./hake",
+        objectDir = Just "./hake"
+    }
+
+    -- Set compilation targets
+    targets <- mapM (\m -> guessTarget m Nothing) source_modules
+    setTargets targets
+    load LoadAllTargets
+
+    -- Import modules
+    setContext
+        ([IIDecl $ simpleImportDecl $ mkModuleName m |
+            m <- modules] ++
+         [IIDecl $ (simpleImportDecl $ mkModuleName m) {
+                ideclQualified = True
+          } | m <- qualified_modules])
+
+    mapM evaluate hakefiles
 
---
--- Return a list of pairs of (Hakefile name, contents)
--- 
-readHakeFiles :: [FilePath] -> IO [ (String,String) ]
-readHakeFiles [] = return []
-readHakeFiles (h:hs) = do { r <- readFile h; 
-                            rs <- readHakeFiles hs;
-                            return ((h,r):rs)
-                          }
---
--- Look for Hakefiles in a list of path names
---
-hakeFiles :: [FilePath] -> [String]
-hakeFiles f = [ fp | fp <- f, isSuffixOf "/Hakefile" fp ]
+    where
+        module_paths = [ (opt_installdir o) </> "hake", ".", 
+                         (opt_bfsourcedir o) </> "hake" ]
+        source_modules = [ "HakeTypes", "RuleDefs", "Path", "Args", "Config" ]
+        modules = [ "Prelude", "HakeTypes", "RuleDefs", "Path", "Args" ]
+        qualified_modules = [ "Config", "Data.List" ]
+
+        evaluate :: (FilePath, String) -> Ghc ((String, HRule))
+        evaluate (hake_name, hake_raw) = do
+            case hake_parse of
+                Left hake_expr -> do
+                    let hake_wrapped =
+                            prettyPrintWithMode (defaultMode {layout = PPNoLayout}) $
+                                wrapHake hake_name hake_expr
+
+                    val <- dynCompileExpr $ hake_wrapped ++ " :: [String] -> HRule"
+                    liftIO $ putStrLn ( "Success: " ++ hake_name )
+                    let rule = fromDyn val (\_ -> Error "failed")
+                    let resolved_rule =
+                            resolveRelativePaths o (rule allfiles) hake_name
+                    return $ (hake_name, resolved_rule)
+                Right hake_error -> do
+                    return $ (hake_name, Error "failed")
+            where
+                hake_parse = parseHake (hake_name, hake_raw)
+
+evalHakeFiles :: Opts -> [FilePath] -> [(FilePath, String)] ->
+                 IO ([(String, HRule)])
+evalHakeFiles o allfiles hakefiles =
+    defaultErrorHandler defaultFatalMessager defaultFlushOut $
+        runGhc (Just libdir) $
+        driveGhc o allfiles hakefiles
+
+parseHake :: (FilePath, String) -> Either Exp HakeError
+parseHake (filename, contents) =
+    case result of
+        ParseOk e -> Left e
+        ParseFailed loc str ->
+            Right $ HakeError (show loc ++ ": " ++ str) 2
+    where
+        result =
+            parseExpWithMode
+                (defaultParseMode {
+                    parseFilename = filename,
+                    baseLanguage = Haskell2010 })
+                contents
+
+wrapHake :: FilePath -> Exp -> Exp
+wrapHake hakefile hake_exp =
+    Paren (
+    Lambda dummy_loc [PVar (Ident "allfiles")] (
+    Let (BDecls
+        [FunBind [Match
+            dummy_loc
+            (Ident "find")
+            [PVar (Ident "fn"), PVar (Ident "arg")]
+            Nothing
+            (UnGuardedRhs
+                (Paren (App (App (App (Var (UnQual (Ident "fn")))
+                                      (Var (UnQual (Ident "allfiles"))))
+                                 (Lit (String hakefile)))
+                       (Var (UnQual (Ident "arg"))))))
+            (BDecls [])],
+
+        FunBind [Match
+            dummy_loc
+            (Ident "build")
+            [PVar (Ident "a")]
+            Nothing
+            (UnGuardedRhs
+                (App (App (App (Paren (App (Var (UnQual (Ident "buildFunction")))
+                                           (Var (UnQual (Ident "a")))))
+                               (Var (UnQual (Ident "allfiles"))))
+                          (Lit (String hakefile)))
+                     (Var (UnQual (Ident "a")))))
+            (BDecls [])]
+        ])
+        (Paren (App (Con (UnQual (Ident "Rules")))
+                    hake_exp))
+    ))
+    where
+        dummy_loc = SrcLoc { srcFilename = "<hake internal>",
+                                srcLine = 0, srcColumn = 0 }
+
+makefilePreamble :: Handle -> Opts -> [String] -> IO ()
+makefilePreamble h opts args = 
+    mapM_ (hPutStrLn h)
+          ([ "# This Makefile is generated by Hake.  Do not edit!",
+             "# ",
+             "# Hake was invoked with the following command line args:" ] ++
+           [ "#        " ++ a | a <- args ] ++
+           [ "# ",
+             "SRCDIR=" ++ (opt_sourcedir opts),
+             "HAKE_ARCHS=" ++ (concat $ intersperse " " Config.architectures),
+             "include ./symbolic_targets.mk" ])
+
+-- a rule is included if it has only "special" architectures and enabled architectures
+allowedArchs :: [String] -> Bool
+allowedArchs = all (\a -> a `elem` (Config.architectures ++ specialArchitectures))
+    where specialArchitectures = ["", "src", "hake", "root", "tools", "docs"]
+
+makefileSection :: Handle -> Opts -> [FilePath] ->
+                   (String, HRule) -> IO (S.Set FilePath)
+makefileSection h opts allfiles (hake_name, rule) = do
+    hPutStrLn h $ "# From: " ++ hake_name ++ "\n"
+    makefileRule h rule
+
+makefileRule :: Handle -> HRule -> IO (S.Set FilePath)
+makefileRule h (Error s) = do
+    hPutStrLn h $ "$(error " ++ s ++ ")\n"
+    return S.empty
+makefileRule h (Rules rules) = do
+    dir_lists <- mapM (makefileRule h) rules
+    return $ S.unions dir_lists
+makefileRule h (Include token) = do
+    when (allowedArchs [frArch token]) $
+        mapM_ (hPutStrLn h) [
+            "ifeq ($(MAKECMDGOALS),clean)",
+            "else ifeq ($(MAKECMDGOALS),rehake)",
+            "else ifeq ($(MAKECMDGOALS),Makefile)",
+            "else",
+            "include " ++ (formatToken token),
+            "endif",
+            "" ]
+    return S.empty
+makefileRule h (HakeTypes.Rule tokens) =
+    if allowedArchs (map frArch tokens)
+        then makefileRuleInner h tokens False
+        else return S.empty
+makefileRule h (Phony name double_colon tokens) = do
+    hPutStrLn h $ ".PHONY: " ++ name
+    makefileRuleInner h (Target "build" name : tokens) double_colon
+
+printTokens :: Handle -> S.Set RuleToken -> IO ()
+printTokens h tokens =
+    S.foldr (\t m -> hPutStr h (formatToken t) >> m) (return ()) tokens
+
+printDirs :: Handle -> S.Set FilePath -> IO ()
+printDirs h dirs =
+    S.foldr (\d m -> hPutStr h (d ++ " ") >> m) (return ()) dirs
+
+makefileRuleInner :: Handle -> [RuleToken] -> Bool -> IO (S.Set FilePath)
+makefileRuleInner h tokens double_colon = do
+    if S.null (ruleOutputs compiledRule)
+    then do
+        hPutStr h "# hake: omitted rule with no output: "
+        doBody
+    else do
+        printTokens h $ ruleOutputs compiledRule
+        if double_colon then hPutStr h ":: " else hPutStr h ": "
+        printTokens h $ ruleDepends compiledRule
+        printDirs h $ ruleDirs compiledRule
+        when (not (S.null (rulePreDepends compiledRule))) $ do
+            hPutStr h " | "
+            printTokens h $ rulePreDepends compiledRule
+        hPutStrLn h ""
+        doBody
+    where
+        compiledRule = compileRule tokens
+
+        doBody :: IO (S.Set FilePath)
+        doBody = do
+            when (ruleBody compiledRule /= []) $ do
+                hPutStr h "\t"
+                mapM_ (hPutStr h . formatToken) $ ruleBody compiledRule
+            hPutStrLn h "\n"
+            return $ ruleDirs compiledRule
 
 ---
 --- Functions to resolve relative path names in rules. 
@@ -149,8 +350,8 @@ hakeFiles f = [ fp | fp <- f, isSuffixOf "/Hakefile" fp ]
 resolveRelativePaths :: Opts -> HRule -> String -> HRule
 resolveRelativePaths o (Rules hrules) root 
     = Rules [ resolveRelativePaths o r root | r <- hrules ]
-resolveRelativePaths o (Rule tokens) root
-    = Rule [ resolveRelativePath o t root | t <- tokens ]
+resolveRelativePaths o (HakeTypes.Rule tokens) root
+    = HakeTypes.Rule [ resolveRelativePath o t root | t <- tokens ]
 resolveRelativePaths o (Include token) root
     = Include ( resolveRelativePath o token root )
 resolveRelativePaths o (Error s) root 
@@ -200,9 +401,9 @@ resolveRelativePathName o InstallTree "root" f h =
 resolveRelativePathName o SrcTree a f h =
     resolveRelativePathName' (opt_sourcedir o) f h
 resolveRelativePathName o BuildTree a f h =
-    resolveRelativePathName' ("." ./. a) f h
+    resolveRelativePathName' ("." </> a) f h
 resolveRelativePathName o InstallTree a f h =
-    resolveRelativePathName' ((opt_installdir o) ./. a) f h
+    resolveRelativePathName' ((opt_installdir o) </> a) f h
 
 --- This is where the work is done: take 'hd' (pathname relative to
 --- us of the Hakefile) and resolve the filename we're interested in
@@ -219,283 +420,140 @@ resolveRelativePathName' d f hd =
         rf = Path.makeRel $ Path.relToDir af "/" 
     in Path.relToDir rf d
 
---
--- Generating a list of build directories
---
-makeDirectories :: [(String, HRule)] -> String
-makeDirectories r = 
-    let alldirs = makeDirs1 (Rules [ rl | (f,rl) <- r ])
-        marker d = d ./. ".marker"
-    in unlines ([ "# Directories follow" ] ++
-                [ "hake_dirs: " ++ (marker d) ++ "\n\n" ++
-                  (marker d) ++ ": \n" ++
-                  "\tmkdir -p " ++ d ++ "\n" ++
-                  "\ttouch " ++ (marker d) ++ "\n"
-                | d <- nub alldirs])
-       
-makeDirs1 :: HRule -> [String]
-makeDirs1 (Rules hrules) = concat [ makeDirs1 r | r <- hrules]
-makeDirs1 (Include tok) = 
-    case tokDir tok of
-      Nothing -> []
-      Just d -> [d]
-makeDirs1 (Rule toks) = [d | Just d <- [ tokDir t | t <- toks ]]
-makeDirs1 (Error s) = []
-makeDirs1 (Phony name dbl toks) = [d | Just d <- [ tokDir t | t <- toks ]]
-
-tokDir :: RuleToken -> Maybe String
-tokDir (In t a f) = tokDir1 f
-tokDir (Out a f) =  tokDir1 f
-tokDir (Dep t a f) =  tokDir1 f
-tokDir (NoDep t a f) =  tokDir1 f
-tokDir (PreDep t a f) =  tokDir1 f
-tokDir (Target a f) =  tokDir1 f
-tokDir (Str s) = Nothing
-tokDir (NStr s) = Nothing
-tokDir (ErrorMsg s) = Nothing
-tokDir NL = Nothing
-
-tokDir1 f 
-    | (Path.dirname f) `Path.isBelow` "." = Just (Path.dirname f)
-    | otherwise = Nothing
-
---
--- filter rules by the set of architectures in Config.architectures
---
-filterRuleByArch :: HRule -> Maybe HRule
-filterRuleByArch (Rule toks) = if allowedArchs (map frArch toks) then Just (Rule toks) else Nothing
-filterRuleByArch (Include tok) = if allowedArchs [frArch tok] then Just (Include tok) else Nothing
-filterRuleByArch (Rules rules) = Just (Rules (catMaybes $ map filterRuleByArch rules))
-filterRuleByArch x = Just x
-
--- a rule is included if it has only "special" architectures and enabled architectures
-allowedArchs :: [String] -> Bool
-allowedArchs = all (\a -> a `elem` (Config.architectures ++ specialArchitectures))
-    where specialArchitectures = ["", "src", "hake", "root", "tools", "docs"]
-
--- 
--- Functions to format rules as Makefile rules
---
-makeMakefile :: [(String, HRule)] -> String
-makeMakefile r = 
-  unlines $ intersperse "" [makeMakefileSection f rl | (f,rl) <- r]
-
-makeMakefileSection :: String -> HRule -> String
-makeMakefileSection fname rules = 
-    "# From: " ++ fname ++ "\n\n" ++ makeMakeRules rules
-
--- Format a rule or rules, of any type (including errors, inclusions,
--- etc.).  See makeMakeRules1 below for how to format rule tokens
--- properly
-makeMakeRules :: HRule -> String
-makeMakeRules (Rules hrules)
-    = unlines [ s | s <- [ makeMakeRules h | h <- hrules ], s /= "" ]
-makeMakeRules (Include token) = unlines [
-    "ifeq ($(MAKECMDGOALS),clean)",
-    "else ifeq ($(MAKECMDGOALS),rehake)",
-    "else ifeq ($(MAKECMDGOALS),Makefile)",
-    "else",
-    "include " ++ (formatToken token),
-    "endif"]
-makeMakeRules (Error s) = "$(error " ++ s ++ ")\n"
-makeMakeRules (Phony name dbl tokens) 
-    = ".PHONY: " ++ name ++ "\n" ++ makeMakeRules1 ([ Target "build" name ] ++ tokens) dbl
-makeMakeRules (Rule tokens) = makeMakeRules1 tokens False
-
--- Now we get down to brass tacks.  Format a rule proper.  Sort out
--- which tokens needs to be in the rule head, dependencies, body, etc.
--- `dbl` specifies a double-colon rule, which is typically used for
--- Phony rules generated as part of the help system.
-makeMakeRules1 :: [RuleToken] -> Bool -> String
-makeMakeRules1 tokens dbl = 
-    let outs = nub [ f | (Out a f) <- tokens ] 
-               ++ [ f | (Target a f) <- tokens ]
-        dirs = nub [ (Path.dirname f) ./. ".marker" | f <- outs ]
-        deps = nub [ f | (In t a f) <- tokens ] ++ [ f | (Dep t a f) <- tokens ] 
-        predeps = nub [ f | (PreDep t a f) <- tokens ] 
-        spaceSep :: [ String ] -> String
-        spaceSep sl = concat (intersperse " " sl)
-        ruleBody = (concat[ formatToken t | t <- tokens, inRule t ])
-    in if outs == [] then
-      ("# hake: omitted rule with no output: " ++ ruleBody)
-    else
-      (spaceSep outs) ++ (if dbl then ":: " else ": ")
-      ++ 
-      -- It turns out that if you add 'dirs' here, in an attempt to
-      -- get Make to build the directories as well, it goes a bit
-      -- pear-shaped: whenever the directory "changes" it goes out of
-      -- date, so you end up rebuilding dependencies every time.
-      (spaceSep (deps ++ dirs)) 
-      ++ 
-      (if (predeps == []) then "" else " | " ++ spaceSep (predeps))
-      ++ "\n" 
-      ++
-      (if (ruleBody == "") then "" else "\t" ++ ruleBody ++ "\n")
-      
-
-preamble :: Opts -> [String] -> String
-preamble opts args = 
-    unlines ( [ "# This Makefile is generated by Hake.  Do not edit!",
-                "# ",
-                "# Hake was invoked with the following command line args:" ] ++
-              [ "#        " ++ a | a <- args ] ++
-              [ "# ",
-                "SRCDIR=" ++ (opt_sourcedir opts),
-                "HAKE_ARCHS=" ++ (concat $ intersperse " " Config.architectures),
-                "include ./symbolic_targets.mk" ] )
-
-stripSrcDir :: String -> String
-stripSrcDir s = Path.removePrefix Config.source_dir s
-
-hakeModule :: [String] -> [(String,String)] -> String
-hakeModule allfiles hakefiles = 
-    let unqual_imports = ["RuleDefs", "HakeTypes", "Path", "Args" ]
-        qual_imports = ["Config", "Data.List" ]
-        relfiles = [ stripSrcDir f | f <- allfiles ]
-        wrap1 n c = wrapLet "build a" 
-                    ("(buildFunction a) allfiles " ++ (show n) ++ " a")
-                    c
-        wrap n c = "(" ++ (show n) ++ ", " 
-                   ++ wrapLet "find fn arg" 
-                          ("(fn allfiles " ++ (show n) ++ " arg)") 
-                          ("Rules (" ++ (wrap1 n c) ++ ")")
-                   ++ ")"
-        flatten :: [String] -> String
-        flatten s = foldl (++) "" (intersperse ",\n" s)
-        addHeader (fn,fc) = (fn, "{-# LINE 1 \"" ++ fn ++ "\" #-}\n" ++ fc)
-        files = flatten [ wrap (stripSrcDir fn) fc | (fn,fc) <- map addHeader hakefiles ]
-    in
-      unlines ( [ "module Hakefiles where {" ]
-                ++
-                [ "import " ++ i ++ ";" | i <- unqual_imports ]
-                ++
-                [ "import qualified " ++ i ++ ";" | i <- qual_imports ] 
-                ++
-                [ "allfiles = " ++ (show relfiles) ++ ";" ]
-                ++ 
-                [ "hf = [" ] 
-              ) ++ files ++ "];\n}"
-
-wrapLet :: String -> String -> String -> String
-wrapLet var expr body = 
-    "(let " ++ var ++ " = " ++ expr ++ " in\n" ++ body ++ ")"
-
-evalHakeFiles :: Opts -> [String] -> [(String,String)] 
-              -> IO [(String,HRule)]
-evalHakeFiles o allfiles hakefiles = 
-    let imports = [ "Hakefiles"]
-        all_imports = ("Prelude":"HakeTypes":imports)
-        moddirs = [ (opt_installdir o) ./. "hake", 
-                    ".", 
-                    (opt_bfsourcedir o) ./. "hake" ]
-    in do 
-      defaultErrorHandler defaultFatalMessager defaultFlushOut $ do
-         runGhc (Just libdir) $ do
-           dflags <- getSessionDynFlags
-          let dflags1 = foldl xopt_set dflags [ Opt_DeriveDataTypeable ]
-          _ <- setSessionDynFlags dflags1{
-               importPaths = moddirs,
-                hiDir = Just "./hake",
-                objectDir = Just "./hake"
-          }
-           targets <- mapM (\m -> guessTarget m Nothing) imports
-           setTargets targets
-           load LoadAllTargets
-           setContext [(IIDecl . simpleImportDecl) (mkModuleName m) | m <- (all_imports)]
-           val <- dynCompileExpr "Hakefiles.hf :: [(String, HRule)]" 
-           return (fromDyn val [("failed",Error "failed")])
-
---
--- Generate dependencies of the Makefile on all the Hakefiles
---
---resolveRelativePaths o (Rules hrules) root 
---- resolveRelativePath o (In t a f) root = 
-makeHakeDeps :: Opts -> [ String ] -> String
-makeHakeDeps o l = 
-    let hake = resolveRelativePath o (In InstallTree "root" "/hake/hake") ""
+makeHakeDeps :: Handle -> Opts -> [String] -> IO ()
+makeHakeDeps h o l = do
+    makefileRule h rule
+    hPutStrLn h ".DELETE_ON_ERROR:\n" -- this applies to all targets in the Makefile
+    where
+        hake = resolveRelativePath o (In InstallTree "root" "/hake/hake") ""
         makefile = resolveRelativePath o (Out "root" (opt_makefilename o)) "/Hakefile"
-        rule = Rule ( [ hake, 
+        rule = HakeTypes.Rule
+                    ( [ hake, 
                         Str "--source-dir", Str (opt_sourcedir o),
                         Str "--install-dir", Str (opt_installdir o),
                         Str "--output-filename", makefile
                       ] ++
                       [ Dep SrcTree "root" h | h <- l ]
                     )
-    in
-     (makeMakeRules rule)
-     ++ ".DELETE_ON_ERROR:\n\n" -- this applies to all targets in the Makefile
-
-makeHakeDeps1 :: Opts -> [ String ] -> String
-makeHakeDeps1 _ l = 
-    "Makefile: ./hake/hake " 
-    ++ concat (intersperse " " l)
-    ++ "\n\t./hake/hake Makefile\n"
-    ++ ".DELETE_ON_ERROR:\n\n" -- this applies to all targets in the Makefile
 
--- check the configuration options, returning an error string if they're insane
-configErrors :: Maybe String
-configErrors
-    | unknownArchs /= [] = Just ("unknown architecture(s) specified: "
-                               ++ (concat $ intersperse ", " unknownArchs))
-    | Config.architectures == [] = Just "no architectures defined"
-    | Config.lazy_thc && not Config.use_fp = Just "Config.use_fp must be true to use Config.lazy_thc."
-    | otherwise = Nothing
+makeDirectories :: Handle -> S.Set FilePath -> IO ()
+makeDirectories h dirs = do
+    hPutStrLn h "# Directories follow"
+    mapM_ (makeDir h) (S.toList (S.delete ("." </> ".marker") dirs))
+
+makeDir :: Handle -> FilePath -> IO ()
+makeDir h dir = do
+    hPutStrLn h $ "hake_dirs: " ++ dir ++ "\n"
+    hPutStrLn h $ dir ++ ":"
+    hPutStrLn h $ "\tmkdir -p " ++ (takeDirectory dir)
+    hPutStrLn h $ "\ttouch " ++ dir
+    hPutStrLn h ""
+
+scanTokens :: [RuleToken] -> (S.Set RuleToken, S.Set RuleToken,
+                              S.Set RuleToken, [RuleToken],
+                              S.Set FilePath)
+scanTokens [] = (S.empty, S.empty, S.empty, [], S.empty)
+scanTokens (t:ts) =
+    case t of
+        Out _ f      -> (S.insert t outs, deps, predeps, body', dirs' f)
+        Target _ f   -> (S.insert t outs, deps, predeps, body', dirs' f)
+        In _ _ f     -> (outs, S.insert t deps, predeps, body', dirs' f)
+        Dep _ _ f    -> (outs, S.insert t deps, predeps, body', dirs' f)
+        PreDep _ _ f -> (outs, deps, S.insert t predeps, body', dirs' f)
+        NoDep _ _ f  -> (outs, deps, predeps, body', dirs' f)
+        _            -> (outs, deps, predeps, body', dirs)
     where
-    unknownArchs = Config.architectures \\ Args.allArchitectures
-
-
----
---- Convert a Hakefile name to one relative to the root of the source tree. 
----
-strip_hfn :: Opts -> String -> String
-strip_hfn opts f = Path.removePrefix (opt_sourcedir opts) f
-
-main :: IO() 
-main = do
+        (outs, deps, predeps, body, dirs) = scanTokens ts
+        body' = if inRule t then t:body else body
+        dirs' f = if Path.isBelow (takeDirectory f) "." &&
+                     takeDirectory f /= "."
+                  then S.insert (dirOf f) dirs else dirs
+
+        dirOf :: FilePath -> FilePath
+        dirOf f = (takeDirectory f) </> ".marker"
+
+
+data CompiledRule =
+    CompiledRule {
+        ruleOutputs    :: S.Set RuleToken,
+        ruleDepends    :: S.Set RuleToken,
+        rulePreDepends :: S.Set RuleToken,
+        ruleBody       :: [RuleToken],
+        ruleDirs       :: S.Set FilePath
+    }
+
+compileRule :: [RuleToken] -> CompiledRule
+compileRule tokens
+    = CompiledRule {
+        ruleOutputs    = outs,
+        ruleDepends    = deps,
+        rulePreDepends = predeps,
+        ruleBody       = body,
+        ruleDirs       = dirs
+        }
+    where
+        (outs, deps, predeps, body, dirs) = scanTokens tokens
+
+gcStats :: IO ()
+gcStats = do
+    performGC
+    gc_stats <- getGCStats
+    putStrLn $ show (currentBytesUsed gc_stats) ++ " - " ++
+               show (numGcs gc_stats) ++ " - " ++
+               show (maxBytesUsed gc_stats) ++ " - " ++
+               show (wallSeconds gc_stats)
+
+body :: HakeMonad ()
+body =  do
     -- parse arguments; architectures default to config file
-    args <- System.Environment.getArgs
+    args <- liftIO $ System.Environment.getArgs
     let o1 = parse_arguments args
         al = if opt_architectures o1 == [] 
              then Config.architectures 
              else opt_architectures o1
         opts = o1 { opt_architectures = al }
-    if opt_usage_error opts then do
-       hPutStrLn stderr usage
-        exitWith $ ExitFailure 1
-      else do
+
+    when (opt_usage_error opts) $
+        throwError (HakeError usage 1)
 
     -- sanity-check configuration settings
     -- this is currently known at compile time, but might not always be!
-    if isJust configErrors then do
-       hPutStrLn stderr $ "Error in configuration: " ++ (fromJust configErrors)
-       exitWith $ ExitFailure 2    
-      else do
-
-    hPutStrLn stdout ("Source directory: " ++ opt_sourcedir opts)
-    hPutStrLn stdout ("BF Source directory: " ++ opt_bfsourcedir opts)
-    hPutStrLn stdout ("Install directory: " ++ opt_installdir opts)
-
-    hPutStrLn stdout "Reading directory tree..."
-    l <- listFilesR (opt_sourcedir opts)
-    hPutStrLn stdout "Reading Hakefiles..."
-    hfl <- readHakeFiles $ hakeFiles l
-    hPutStrLn stdout "Writing HakeFile module..."
-    modf <- openFile ("Hakefiles.hs") WriteMode
-    hPutStrLn modf $ hakeModule l hfl
-    hClose modf
-    hPutStrLn stdout "Evaluating Hakefiles..."
-    inrules <- evalHakeFiles opts l hfl
-    hPutStrLn stdout "Done!"
-    -- filter out rules for unsupported architectures and resolve relative paths
-    let rules = 
-          ([(f, resolveRelativePaths opts (fromJust (filterRuleByArch rl)) (strip_hfn opts f))
-           | (f,rl) <- inrules, isJust (filterRuleByArch rl) ])
-    hPutStrLn stdout $ "Generating " ++ (opt_makefilename opts) ++ " - this may take some time (and RAM)..." 
-    makef <- openFile(opt_makefilename opts) WriteMode
-    hPutStrLn makef $ preamble opts args
-    -- let hfl2 = [ strip_hfn opts (fst h) | h <- hfl ]
-    hPutStrLn makef $ makeHakeDeps opts $ map fst hfl
-    hPutStrLn makef $ makeMakefile rules
-    hPutStrLn makef $ makeDirectories rules
-    hClose makef
+    when (isJust configErrors) $
+        throwError (HakeError ("Error in configuration: " ++
+                               (fromJust configErrors)) 2)
+
+    liftIO $ putStrLn ("Source directory: " ++ opt_sourcedir opts)
+    liftIO $ putStrLn ("BF Source directory: " ++ opt_bfsourcedir opts)
+    liftIO $ putStrLn ("Install directory: " ++ opt_installdir opts)
+
+    liftIO gcStats
+
+    liftIO $ putStrLn "Reading directory tree..."
+    (allfiles, hakefiles) <- liftIO $ listFiles (opt_sourcedir opts)
+
+    liftIO gcStats
+
+    rules <- liftIO $ evalHakeFiles opts allfiles hakefiles
+    liftIO $ putStrLn $ show (length rules)
+
+    liftIO gcStats
+
+    liftIO $ putStrLn $ "Generating " ++ (opt_makefilename opts)
+    makefile <- liftIO $ openFile(opt_makefilename opts) WriteMode
+    liftIO $ makefilePreamble makefile opts args
+    liftIO $ makeHakeDeps makefile opts $ map fst hakefiles
+    dirs <- liftIO $ mapM (makefileSection makefile opts allfiles) rules
+    liftIO $ makeDirectories makefile (S.unions dirs)
+
+    liftIO gcStats
+
+    return ()
+
+main :: IO () 
+main = do
+    r <- runErrorT $ body `catchError` handleFailure
     exitWith ExitSuccess
+    where
+        handleFailure (HakeError str n) = do
+            liftIO $ putStrLn str
+            liftIO $ exitWith (ExitFailure n)
index 04ecc04..3ce5497 100755 (executable)
@@ -156,6 +156,7 @@ fi
 echo "Building hake..."
 ghc -O --make -XDeriveDataTypeable \
     -package ghc \
+    -package ghc-mtl \
     -package ghc-paths \
     -o hake/hake \
     -outputdir hake \
@@ -163,7 +164,6 @@ ghc -O --make -XDeriveDataTypeable \
     -ihake \
     -rtsopts=all \
     -threaded \
-    -with-rtsopts="-K32m" \
     $SRCDIR/hake/Main.hs $LDFLAGS || exit 1
 
     # -eventlog \
@@ -175,7 +175,8 @@ fi
 
 echo "Running hake..."
 #./hake/hake --output-filename Makefile --source-dir "$SRCDIR" +RTS -s -N -K64M -A64M -ls -lf || exit
-./hake/hake --output-filename Makefile --source-dir "$SRCDIR" +RTS -N -K64M -A64M || exit
+#./hake/hake --output-filename Makefile --source-dir "$SRCDIR" +RTS -N -K64M -A64M || exit
+./hake/hake --output-filename Makefile --source-dir "$SRCDIR" +RTS -T || exit
 
 echo "Now running initial make to build dependencies."
 echo " (remove the '-j 4' if your system has trouble handling this"