Main.hs

{-
  Hake: a meta build system for Barrelfish

  Copyright (c) 2009, 2015, 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, Universitaetstasse 6, CH-8092 Zurich. Attn: Systems Group.
-}



-- Asynchronous IO for walking directories
import Control.Concurrent.Async
import Control.DeepSeq

import Control.Exception.Base
import Control.Monad

import Exception

import Data.Dynamic
import Data.List
import Data.Maybe
import Data.Char
import qualified Data.Set as S
import qualified Data.Map.Strict as Map

import System.Directory
import System.Environment
import System.Exit
import System.FilePath
import System.IO
import Debug.Trace

-- The GHC API.  We use the mtl-compatible version in order to use liftIO
-- within the GHC monad.
import GHC hiding (Target, Ghc, runGhc, FunBind, Match)
import GHC.Paths (libdir)
import Control.Monad.Ghc

-- We parse and pretty-print Hakefiles.
import Language.Haskell.Exts


-- Hake components
import RuleDefs
import HakeTypes
import qualified Args
import qualified Config
import TreeDB
import LibDepTree

data HakeError = HakeError String Int
    deriving (Show, Typeable)
instance Exception HakeError

--
-- Command line options and parsing code
--
data Opts = Opts { opt_makefilename :: String,
                   opt_installdir :: String,
                   opt_sourcedir :: String,
                   opt_bfsourcedir :: String,
                   opt_builddir :: String,
                   opt_ghc_libdir :: String,
                   opt_abs_installdir :: String,
                   opt_abs_sourcedir :: String,
                   opt_abs_bfsourcedir :: String,
                   opt_abs_builddir :: 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_builddir = ".",
         opt_ghc_libdir = libdir,
         opt_abs_installdir = "",
         opt_abs_sourcedir = "",
         opt_abs_bfsourcedir = "",
         opt_abs_builddir = "",
         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 ("--build-dir" : s : t) =
  (parse_arguments t) { opt_builddir = s }
parse_arguments ("--ghc-libdir" : (s : t)) =
  (parse_arguments t) { opt_ghc_libdir = 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)",
                  "   --ghc-libdir <dir> (defaults to " ++ libdir ++ ")",
                  "   --quiet",
                  "   --verbose"
                ]

-- Check the configuration options, returning an error string if they're
-- invalid.
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 the source tree and build a complete list of pathnames, loading any
-- Hakefiles.
listFiles :: FilePath -> IO ([FilePath], [(FilePath, String)])
listFiles root = listFiles' root root

listFiles' :: FilePath -> FilePath -> IO ([FilePath], [(FilePath, String)])
listFiles' root current
    | ignore (takeFileName current) = return ([], [])
    | otherwise = do
        isdir <- doesDirectoryExist current
        if isdir then do
            children <- getDirectoryContents current
            walkchildren $ filter isRealChild children
        else do
            hake <- maybeHake current
            return ([makeRelative root current], hake)
    where
        -- Walk the child directories in parallel.  This speeds things up
        -- dramatically over NFS, with its high latency.
        walkchildren :: [FilePath] -> IO ([FilePath], [(FilePath, String)])
        walkchildren children = do
            children_async <- mapM (async.walkchild) children
            results <- mapM wait children_async
            return $ joinResults results

        joinResults :: [([a],[b])] -> ([a],[b])
        joinResults [] = ([],[])
        joinResults ((as,bs):xs) =
            let (as',bs') = joinResults xs in
                (as ++ as', bs ++ bs')

        walkchild :: FilePath -> IO ([FilePath], [(FilePath, String)])
        walkchild child = listFiles' root (current </> child)

        -- Load Hakfiles eagerly.  This amounts to <1MB for Barrelfish (2015).
        maybeHake path
            | takeFileName path == "Hakefile" = do
                contents <- readFile path
                return [(path, contents)]
            | otherwise = return []

        -- Don't descend into revision-control or build directories.
        ignore :: FilePath -> Bool
        ignore "CMakeFiles" = True
        ignore ".hg"        = True
        ignore ".git"       = True
        ignore ('.':[])     = False
        ignore ('.':xs)     = True
        ignore "build"      = True
        ignore _            = False

        -- We ignore self-links and parent-links
        isRealChild :: FilePath -> Bool
        isRealChild "."  = False
        isRealChild ".." = False
        isRealChild _    = True

--
-- Hake parsing using the GHC API
--

-- We invoke GHC to parse the Hakefiles in a preconfigured environment,
-- to implement the Hake DSL.
evalHakeFiles :: FilePath -> Opts -> TreeDB -> [(FilePath, String)] ->
                 (FilePath -> HRule -> Ghc a) -> IO ([a])
evalHakeFiles the_libdir o srcDB hakefiles rulef =
    --defaultErrorHandler defaultFatalMessager defaultFlushOut $
    errorHandler $
        runGhc (Just the_libdir) $
        driveGhc o srcDB hakefiles rulef

-- This is the code that executes in the GHC monad.
driveGhc :: forall a. Opts -> TreeDB -> [(FilePath, String)] ->
            (FilePath -> HRule -> Ghc a) -> Ghc ([a])
driveGhc o srcDB hakefiles rulef = do
    -- Set the RTS flags
    dflags <- getSessionDynFlags
    _ <- setSessionDynFlags dflags {
        importPaths = module_paths,
        hiDir = Just "./hake",
        objectDir = Just "./hake"
    }

    -- Set compilation targets i.e. everything that needs to be built from
    -- source (*.hs).
    targets <- mapM (\m -> guessTarget m Nothing) source_modules
    setTargets targets
    load LoadAllTargets

    -- Import both system and Hake modules.
    setContext
        ([IIDecl $ simpleImportDecl $ mkModuleName m |
            m <- modules] ++
         [IIDecl $ (simpleImportDecl $ mkModuleName m) {
                ideclQualified = True
          } | m <- qualified_modules])

    -- Collect rules from Hakefiles
    collectRules hakefiles

    where
        module_paths = [ (opt_installdir o) </> "hake", ".",
                         (opt_bfsourcedir o) </> "hake" ]
        source_modules = [ "HakeTypes", "RuleDefs", "Args", "Config",
                           "TreeDB" ]
        modules = [ "Prelude", "System.FilePath", "HakeTypes", "RuleDefs",
                    "Args", "TreeDB"  ]
        qualified_modules = [ "Config", "Data.List" ]

        -- Evaluate one Hakefile, and emit its Makefile section.  We collect
        -- referenced directories as we go, to generate the 'directories'
        -- rules later.
        collectRules' :: [a] -> [(FilePath, String)] -> Ghc ([a])
        collectRules' rules [] = return rules
        collectRules' rules ((abs_hakepath, contents):hs) = do
            let hakepath = makeRelative (opt_sourcedir o) abs_hakepath
            rule <- evaluate hakepath contents
            ruleout <- rulef hakepath rule
            collectRules' (ruleout : rules) hs

        collectRules :: [(FilePath, String)] -> Ghc ([a])
        collectRules hs = collectRules' [] hs

        -- Evaluate a Hakefile, returning something of the form
        -- Rule [...]
        evaluate :: FilePath -> String -> Ghc HRule
        evaluate hakepath hake_raw = do
            case hake_parse of
                Left hake_expr -> do
                    let hake_wrapped =
                            prettyPrintWithMode (defaultMode {layout = PPNoLayout}) $
                                wrapHake hakepath hake_expr

                    -- Evaluate in GHC
                    val <- ghandle handleFailure $
                                dynCompileExpr -- $ traceShowId
                                $ hake_wrapped ++ " :: TreeDB -> HRule"



                    rule <-
                        case fromDynamic val of
                            Just r -> return r
                            Nothing -> throw $
                                HakeError (hakepath ++
                                           " - Compilation failed") 1

                    -- Path resolution
                    let resolved_rule =
                            resolvePaths o (takeDirectory hakepath)
                                           (rule srcDB)
                    return resolved_rule
                Right hake_error -> throw hake_error
            where
                hake_parse = parseHake hakepath hake_raw

                handleFailure :: SomeException -> Ghc Dynamic
                handleFailure e
                    = throw $ HakeError (hakepath ++ ":\n" ++ show e) 1

errorHandler :: (ExceptionMonad m, MonadIO m) => m a -> m a
errorHandler inner =
  ghandle (\exception -> liftIO $ do
           hFlush stdout
           handleIOException exception
           handleAsyncException exception
           handleExitException exception
           handleHakeError exception
           throw exception
          ) $

  -- error messages propagated as exceptions
  ghandle
            (\(ge :: GhcException) -> liftIO $ do
                hFlush stdout
                throw $ HakeError (show ge) 1
            ) $
  inner
  where
    handleIOException e =
        case fromException e of
            Just (ioe :: IOException) ->
                throw $ HakeError ("IO Exception: " ++ (show ioe)) 1
            _ -> return ()

    handleAsyncException e =
        case fromException e of
            Just UserInterrupt ->
                throw $ HakeError "Interrupted" 1
            Just StackOverflow ->
                throw $ HakeError ("Stack Overflow: use +RTS " ++
                                   "-K<size> to increase it") 1
            _ -> return ()

    handleExitException e =
        case fromException e of
            Just ExitSuccess ->
                throw $ HakeError "GHC terminated early" 1
            Just (ExitFailure n) ->
                throw $ HakeError "GHC terminated early" n
            _ -> return ()

    handleHakeError e =
        case fromException e of
            Just (HakeError s n) -> throw $ HakeError s n
            _ -> return ()

printSrcLoc :: Language.Haskell.Exts.SrcLoc -> String
printSrcLoc sl =
    srcFilename sl ++ ":" ++
    (show $ srcLine sl) ++ "." ++
    (show $ srcColumn sl)

-- Parse a Hakefile, prior to wrapping it with Hake definitions
parseHake :: FilePath -> String -> Either (Exp SrcSpanInfo) HakeError
parseHake filename contents =
    case result of
        ParseOk e -> Left e
        ParseFailed loc str ->
            Right $ HakeError (printSrcLoc loc ++ " - " ++ str) 1
    where
        result =
            parseExpWithMode
                (defaultParseMode {
                    parseFilename = filename,
                    baseLanguage = Haskell2010 })
                contents

-- Split a Hake rule up by token type.  It's more efficient to do this
-- in a single pass, than to filter each as it's required.
data CompiledRule =
    CompiledRule {
        ruleOutputs    :: S.Set RuleToken,
        ruleDepends    :: S.Set RuleToken,
        rulePreDepends :: S.Set RuleToken,
        ruleBody       :: [RuleToken],
        ruleDirs       :: S.Set FilePath
    }


-- Get the relative rule from an absolute rule pair
makeRelativeRule :: RuleToken -> RuleToken
makeRelativeRule (Abs _ t) = t
makeRelativeRule t = t

compileRule :: [RuleToken] -> CompiledRule
compileRule [] = CompiledRule S.empty  S.empty  S.empty  []  S.empty
compileRule (t:ts) =
    let CompiledRule outs deps predeps body dirs = compileRule ts
        outs'    = if isOutput t then S.insert (makeRelativeRule t) outs else outs
        deps'    = if isDependency t then S.insert (makeRelativeRule t) deps else deps
        predeps' = if isPredependency t then S.insert (makeRelativeRule t) predeps else predeps
        body'    = if inRule t then t:body else body
        dirs'    = if isFileRef t &&
                      inTree (frPath t) &&
                      takeDirectory (frPath t) /= "."
                   then S.insert (replaceFileName (frPath t) ".marker") dirs
                   else dirs
    in
    CompiledRule outs' deps' predeps' body' dirs'
    where
        inTree :: FilePath -> Bool
        inTree p =
            case splitDirectories p of
                "..":_ -> False
                "/":_ -> False
                _ -> True

-- We wrap the AST of the parsed Hakefile to defind the 'find' and 'build'
-- primitives, and generate the correct expression type (HRule).  The result
-- is an unevaluted function [FilePath] -> HRule, that needs to be supplied
-- with the list of all files in the source directory.
wrapHake :: FilePath -> Exp SrcSpanInfo -> Exp SrcSpanInfo
wrapHake hakefile hake_exp =
  Paren loc (
    Lambda loc [PVar loc (Ident loc "sourceDB")] (
      Let loc (
        BDecls loc [
          FunBind loc [
             -- This is 'find'
            Match loc (Ident loc "find")
              [PVar loc (Ident loc "fn"), PVar loc (Ident loc "arg")]
              -- Nothing
              (UnGuardedRhs  loc
                  (Paren  loc (App loc  (App loc  (App loc  (Var loc  (UnQual loc  (Ident loc  "fn")))
                                        (Var loc  (UnQual loc  (Ident loc  "sourceDB"))))
                                   (Lit loc  (String loc hakefile "")))
                         (Var loc  (UnQual loc  (Ident loc  "arg"))))))
              (Just (BDecls loc  []))
          ],

          FunBind loc [
            Match loc
              (Ident loc "build") -- This is 'build'
              [PVar loc (Ident loc "a")]
              (UnGuardedRhs loc
                  (App loc (App loc (App loc (Paren loc (App loc (Var loc (UnQual loc (Ident loc "buildFunction")))
                                             (Var loc (UnQual loc (Ident loc "a")))))
                                 (Var loc (UnQual loc (Ident loc "sourceDB"))))
                            (Lit  loc(String loc hakefile "")))
                       (Var loc (UnQual loc (Ident loc "a")))))
              (Just (BDecls loc []))
          ]
        ]
      ) (Paren loc (App loc (Con loc (UnQual loc (Ident loc "Rules"))) hake_exp))
    )
  )
    where
        dummy_loc = SrcLoc { srcFilename = "<hake internal>",
                                srcLine = 0, srcColumn = 0 }
        loc = Language.Haskell.Exts.noSrcSpan
--
-- Makefile generation
--

-- The Makefile header, generated once.
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 ] ++
           [ "# ",
             "Q=@",
             "SRCDIR=" ++ opt_sourcedir opts,
             "HAKE_ARCHS=" ++ intercalate " " Config.architectures,
             -- Disable built-in implicit rules. GNU make adds environment's MAKEFLAGS too.
             "MAKEFLAGS=r",
             -- Explicitly disable the flex and bison implicit rules
             "%.c : %.y",
             "%.c : %.l",
             "INSTALL_PREFIX ?= /home/netos/tftpboot/$(USER)" ])

-- There a several valid top-level build directores, apart from the
-- architecture-specific one.
arch_list :: S.Set String
arch_list = S.fromList (Config.architectures ++
                        ["", "src", "hake", "root", "tools", "docs", "cache"])

-- A rule is included if it applies to only "special" and configured
-- architectures.
allowedArchs :: [String] -> Bool
allowedArchs = all (\a -> a `S.member` arch_list)


-- The section corresponding to a Hakefile.  These routines all collect
-- and directories they see.
makefileSectionArr :: Handle -> Opts -> [(FilePath,HRule)] -> IO (S.Set FilePath)
makefileSectionArr h opts xs = makefileSectionArr' S.empty xs
  where
    makefileSectionArr' :: (S.Set FilePath) -> [(FilePath,HRule)] ->
      IO (S.Set FilePath)
    makefileSectionArr' dirs [] = return dirs
    makefileSectionArr' dirs ((fp,rule) : xs) = do
      dirs' <- makefileSection h opts fp rule
      makefileSectionArr' (S.union dirs' dirs) xs

makefileSection :: Handle -> Opts -> FilePath -> HRule -> IO (S.Set FilePath)
makefileSection h opts hakepath rule = do
    hPutStrLn h $ "# From: " ++ hakepath ++ "\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
    if allowedArchs (map frArch tokens)
        then do
            hPutStrLn h $ ".PHONY: " ++ name
            makefileRuleInner h (Target "build" name : tokens) double_colon
        else return S.empty

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
        return $ ruleDirs compiledRule
    else do
        printTokens h $ ruleOutputs compiledRule
        if double_colon then hPutStr h ":: " else hPutStr h ": "
        printTokens h $ ruleDepends compiledRule
        hPutStr h " | directories "
        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 path names in rules.
--
-- Absolute paths are interpreted relative to one of the three trees: source,
-- build or install.  Relative paths are interpreted relative to the directory
-- containing the Hakefile that referenced them, within one of the above tree.
-- Both build and install trees are divided by architecture, while the source
-- tree is not.  All paths are output relative to the build directory.
--
-- For example, if we are building for architecture 'x86_64', with build tree
-- '/home/user/barrelfish/build' and build tree '/home/user/barrelfish'
-- relative path '../', and we are compiling a Hakefile at 'apps/init/Hakefile'
-- relative path  '../apps/init/Hakefile', we would resolve as follows:
--
--   In SourceTree "../apps/init" "x86_64" "main.c"
--      -> "../apps/init/main.c"
--   In BuildTree "../apps/init" "x86_64" "/include/generated.h"
--      -> "./x86_64/include/generated.h"
--   Out BuildTree "../apps/init" "root" "/doc/manual.pdf"
--      -> "./doc/manual.pdf"
--
-- Note that the 'root' architecture is special, and always refers to the root
-- of the relevant tree.

-- Recurse through the Hake AST
resolvePaths :: Opts -> FilePath -> HRule -> HRule
resolvePaths o hakepath (Rules hrules)
    = Rules $ map (resolvePaths o hakepath) hrules
resolvePaths o hakepath (HakeTypes.Rule tokens)
    = HakeTypes.Rule $ map (resolveTokenPath o hakepath) tokens
resolvePaths o hakepath (Include token)
    = Include $ resolveTokenPath o hakepath token
resolvePaths o hakepath (Error s)
    = Error s
resolvePaths o hakepath (Phony name dbl tokens)
    = Phony name dbl $ map (resolveTokenPath o hakepath) 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).
resolveTokenPath :: Opts -> FilePath -> RuleToken -> RuleToken
-- An input token specifies which tree it refers to.
resolveTokenPath o hakepath (In tree arch path) =
    (In tree arch (treePath o tree arch path hakepath))
-- An output token implicitly refers to the build tree.
resolveTokenPath o hakepath (Out arch path) =
    (Out arch (treePath o BuildTree arch path hakepath))
-- A dependency token specifies which tree it refers to.
resolveTokenPath o hakepath (Dep tree arch path) =
    (Dep tree arch (treePath o tree arch path hakepath))
-- A non-dependency token specifies which tree it refers to.
resolveTokenPath o hakepath (NoDep tree arch path) =
    (NoDep tree arch (treePath o tree arch path hakepath))
-- A pre-dependency token specifies which tree it refers to.
resolveTokenPath o hakepath (PreDep tree arch path) =
    (PreDep tree arch (treePath o tree arch path hakepath))
-- An target token implicitly refers to the build tree.
resolveTokenPath o hakepath (Target arch path) =
    (Target arch (treePath o BuildTree arch path hakepath))
-- A target token referring to an absolute resource
resolveTokenPath o hakepath (Abs rule rule2) =
    let o' = o {
            opt_sourcedir = opt_abs_sourcedir o,
            opt_installdir = opt_abs_installdir o,
            opt_builddir = opt_abs_builddir o,
            opt_bfsourcedir = opt_abs_bfsourcedir o
        }
    in Abs (resolveTokenPath o' hakepath rule) (resolveTokenPath o hakepath rule2)
-- Other tokens don't contain paths to resolve.
resolveTokenPath _ _ token = token

-- Now we get down to the nitty gritty.  We have, in order:
--   o:        The options in force
--   tree:     The tree (source, build, or install)
--   arch:     The architecture (e.g. armv7)
--   path:     The pathname we want to resolve
--   hakepath: The directory containing the Hakefile
-- 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.
treePath :: Opts -> TreeRef -> FilePath -> FilePath -> FilePath -> FilePath
-- The architecture 'root' is special.
treePath o SrcTree "root" path hakepath =
    relPath (opt_sourcedir o) path hakepath
treePath o BFSrcTree "root" path hakepath =
    relPath (opt_bfsourcedir o) path hakepath
treePath o BuildTree "root" path hakepath =
    relPath (opt_builddir o) path hakepath
treePath o InstallTree "root" path hakepath =
    relPath (opt_installdir o) path hakepath
-- The architecture 'cache' is special.
treePath o SrcTree "cache" path hakepath =
    relPath Config.cache_dir path hakepath
treePath o BFSrcTree "cache" path hakepath =
    relPath Config.cache_dir path hakepath
treePath o BuildTree "cache" path hakepath =
    relPath Config.cache_dir path hakepath
treePath o InstallTree "cache" path hakepath =
    relPath Config.cache_dir path hakepath
-- Source-tree paths don't get an architecture.
treePath o SrcTree arch path hakepath =
    relPath (opt_sourcedir o) path hakepath
treePath o BFSrcTree arch path hakepath =
    relPath (opt_bfsourcedir o) path hakepath
treePath o BuildTree arch path hakepath =
    relPath ((opt_builddir o) </> arch) path hakepath
treePath o InstallTree arch path hakepath =
    relPath (opt_installdir o </> arch) path hakepath

-- First evaluate the given path 'path', relative to the Hakefile directory
-- 'hakepath'.  If 'path' is absolute (i.e. begins with a /), it is unchanged.
-- Otherwise it is appended to 'hakepath'.  We then treat this as a relative
-- path (by removing any initial /), and append it to the relevant tree root
-- (which may or may not have an architecture path appended already).
relPath :: String -> String -> String -> String
-- The first rule prevents a path of / to be reduced to the empty string
relPath "." "/" hakepath =
    "."
relPath "." path hakepath =
    stripSlash (hakepath </> path)
relPath treeroot path hakepath =
    treeroot </> stripSlash (hakepath </> path)

-- Strip any leading slash from the filename.  This is much faster than
-- 'makeRelative "/"'.
stripSlash :: FilePath -> FilePath
stripSlash ('/':cs) = cs
stripSlash cs = cs

-- Emit the rule to rebuild the Hakefile.
makeHakeDeps :: Handle -> Opts -> [String] -> IO ()
makeHakeDeps h o l = do
    hPutStrLn h "ifneq ($(MAKECMDGOALS),rehake)"
    makefileRule h rule
    hPutStrLn h "endif"
    hPutStrLn h ".DELETE_ON_ERROR:\n" -- this applies to following targets.
    where
        hake = resolveTokenPath o "" (In InstallTree "root" "/hake/hake")
        makefile = resolveTokenPath o "/" (Out "root" (opt_makefilename o))
        rule = HakeTypes.Rule
                    ( [ hake,
                        Str "--source-dir", Str (opt_sourcedir o),
                        Str "--install-dir", Str (opt_installdir o),
                        Str "--bfsource-dir", Str (opt_bfsourcedir o),
                        Str "--output-filename", makefile,
                        Str "--ghc-libdir", Str (opt_ghc_libdir o)
                      ] ++
                      [ Dep SrcTree "root" h | h <- l ]
                    )

-- Emit the rules to create the build directories
makeDirectories :: Handle -> S.Set FilePath -> IO ()
makeDirectories h dirs = do
    hPutStrLn h "# Directories follow"
    hPutStrLn h "DIRECTORIES=\\"
    mapM_ (\d -> hPutStrLn h $ "    " ++ d ++ " \\") (S.toList dirs)
    hPutStrLn h "\n"
    hPutStrLn h ".PHONY: directories"
    hPutStr h "directories: $(DIRECTORIES)"
    hPutStrLn h ""
    hPutStrLn h "%.marker:"
    hPutStrLn h "\t$(Q)echo \"MKDIR $@\""
    hPutStrLn h "\t$(Q)mkdir -p `dirname $@`"
    hPutStrLn h "\t$(Q)touch $@"

makeDriverDomainDb :: String -> LibDepTree2 -> IO()
makeDriverDomainDb build t = do
  let fileName = build ++ "/sockeyefacts/ddomain_db.pl"
  let dirName = build ++ "/sockeyefacts"
  createDirectoryIfMissing True dirName
  writeFile fileName ""
  h <- openFile(fileName) WriteMode
  mapM_ (hPutStrLn h . pairToPl) (ldtDriverModules t)
  hFlush h
  hClose h
  return ()
  where
    pairToPl :: (DepEl, DepEl) -> String
    pairToPl (a,b) = "drivermodule(" ++ toPl a ++ "," ++ toPl b ++ ")."
    toPl :: DepEl -> String
    toPl x = "(\"" ++ depElArch x ++ "\",\"" ++ depElName x ++ "\")"


--
-- The top level
--

extractrule :: FilePath -> HRule -> Ghc (HRule)
extractrule fp hr = return hr

extractDep :: FilePath -> HRule -> Ghc (DepElMap)
extractDep fp hr = return $ ldtHRuleToDepElMap Config.architectures hr

writeMF :: Handle -> Opts -> (HRule -> HRule) -> FilePath -> HRule -> Ghc (S.Set FilePath)
writeMF h o rule_transform fp rule = liftIO $ makefileSection h o fp (rule_transform rule)

body :: IO ()
body =  do
    -- Parse arguments; architectures default to config file
    args <- 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') $
        throw (HakeError usage 1)

    -- Check configuration settings.
    -- This is currently known at compile time, but might not always be!
    when (isJust configErrors) $
        throw (HakeError ("Error in configuration: " ++
                         (fromJust configErrors)) 2)

    -- Canonicalise directories
    abs_sourcedir   <- canonicalizePath $ opt_sourcedir opts'
    abs_bfsourcedir <- canonicalizePath $ opt_bfsourcedir opts'
    abs_installdir  <- canonicalizePath $ opt_installdir opts'
    abs_builddir    <- canonicalizePath $ "."
    let opts = opts' { opt_abs_sourcedir   = abs_sourcedir,
                       opt_abs_bfsourcedir = abs_bfsourcedir,
                       opt_abs_installdir  = abs_installdir,
                       opt_abs_builddir    = abs_builddir }

    putStrLn ("Source directory: " ++ opt_sourcedir opts ++
                       " (" ++ opt_abs_sourcedir opts ++ ")")
    putStrLn ("BF Source directory: " ++ opt_bfsourcedir opts ++
                       " (" ++ opt_abs_bfsourcedir opts ++ ")")
    putStrLn ("Install directory: " ++ opt_installdir opts ++
                       " (" ++ opt_abs_installdir opts ++ ")")
    putStrLn ("GHC libdir: " ++ opt_ghc_libdir opts)

    -- Find Hakefiles
    putStrLn "Scanning directory tree..."
    (relfiles, hakefiles) <- listFiles (opt_sourcedir opts)
    let srcDB = tdbBuild relfiles

    -- Open the Makefile and write the preamble
    putStrLn $ "Creating " ++ (opt_makefilename opts) ++ "..."
    makefile <- openFile(opt_makefilename opts) WriteMode
    makefilePreamble makefile opts args
    makeHakeDeps makefile opts $ map fst hakefiles

    -- Evaluate Hakefiles
    putStrLn $ "Evaluating " ++ show (length hakefiles) ++ " Hakefiles for dependencies..."
    depElMap <- evalHakeFiles (opt_ghc_libdir opts) opts srcDB hakefiles extractDep

    let dep_graph = ldtEmToGraph (foldr ldtDepElMerge Map.empty depElMap)
    let rtrans = ldtRuleExpand $ dep_graph
    putStrLn $ "Evaluating " ++ show (length hakefiles) ++ " Hakefiles..."

    dirs_a <- evalHakeFiles (opt_ghc_libdir opts) opts srcDB hakefiles (writeMF makefile opts rtrans)

    let dirs = foldr S.union S.empty dirs_a

    putStrLn "Generating build directory dependencies..."
    makeDirectories makefile dirs

    makeDriverDomainDb abs_builddir dep_graph

    hFlush makefile
    hClose makefile
    return ()

main :: IO ()
main = do
    r <- body `catch` handleHakeError
    exitWith ExitSuccess
    where
        handleHakeError :: HakeError -> IO ()
        handleHakeError (HakeError str n) = do
            putStrLn str
            exitWith $ ExitFailure n