module Main where
import DynFlags(defaultDynFlags)
import GHC
import Util(looksLikeModuleName)
import StaticFlags(parseStaticFlags)
import DriverPhases(startPhase, Phase(..), isSourceFilename, isHaskellSrcFilename)
import System(getArgs, exitWith, ExitCode(ExitSuccess, ExitFailure))
import System.Info(os)
import Monad(when)
import List(partition)
import IO(putStrLn, {-hSetBuffering, BufferMode(NoBuffering), stdin, stdout, stderr-})
import Char(toUpper)

-- You will need to change this to point to your GHC 6.5 snapshot directory
pathToGHC = "c:\\projects\\ghc-clean\\6.6-perf\\installed"

main = defaultErrorHandler defaultDynFlags $ do
    initialArgs <- getArgs
    dynArgs <- parseStaticFlags initialArgs
    s       <- newSession BatchCompile  (Just pathToGHC)
    initialFlags <- getSessionDynFlags s
    (dynamicFlags, fileish_args) <- parseDynamicFlags (initialFlags { verbosity = 1 }) dynArgs
    setSessionDynFlags s dynamicFlags

        -- To simplify the handling of filepaths, we normalise all filepaths right 
        -- away - e.g., for win32 platforms, backslashes are converted
        -- into forward slashes.
    let normal_fileish_paths = map normalisePath fileish_args
    let (srcs, objs)         = partition_args normal_fileish_paths [] []
    prepareMake s srcs
    x <- doMakeLoop s
    return x

-- Make the program, then ask the user if they want to re-make or quit
doMakeLoop :: Session -> IO SuccessFlag
doMakeLoop s = do 
    x <- doMake s
    case x of 
        Succeeded -> putStrLn "\nSucceeded!\n"
        _ -> putStrLn "\nFailed!\n"
    doInputLoop s x

-- Keep asking the user what to do until they say something reasonable,
-- and then do as they say
doInputLoop :: Session -> SuccessFlag -> IO SuccessFlag
doInputLoop s x = do 
    {-hSetBuffering stdin NoBuffering
    hSetBuffering stdout NoBuffering
    hSetBuffering stderr NoBuffering -}
    putStrLn "Press [enter] to remake or type \"quit\" and enter to quit"
    command <- getLine
    case map toUpper command of 
        c | c == "QUIT" -> return x
        []  -> doMakeLoop s
        bad -> do putStrLn $ "Invalid input: \"" ++ bad ++ "\""
                  doInputLoop s x

-- The part of GHC's Main.hs/doMake that only needs to be executed once
-- per session
prepareMake sess srcs = do    
    -- let hs_srcs = srcs
    let (hs_srcs, non_hs_srcs) = partition haskellish srcs
        haskellish (f,Nothing) = 
            looksLikeModuleName f || isHaskellSrcFilename f || '.' `notElem` f
        haskellish (f,Just phase) = 
            phase `notElem` [As, Cc, CmmCpp, Cmm, StopLn]

    dflags <- GHC.getSessionDynFlags sess
    -- o_files <- mapM (compileFile dflags StopLn) non_hs_srcs
    -- mapM_ (consIORef v_Ld_inputs) (reverse o_files)

    targets <- mapM (uncurry GHC.guessTarget) hs_srcs
    GHC.setTargets sess targets

-- The part of GHC's Main.hs/doMake that needs to be executed every build
doMake sess = do
    -- revertCAFs  
    dflags <- getSessionDynFlags sess
    GHC.defaultCleanupHandler dflags $ load sess LoadAllTargets

-- -----------------------------------------------------------------------
-- Everything below this point is just copy/pasted from the GHC source code.
-- They are all utilities for dealing with command line arguments

normalisePath xs | os == "mingw32" = subst '\\' '/' xs
                 | otherwise       = error "foo"
    where
    subst a b ls = map (\ x -> if x == a then b else x) ls

-- -----------------------------------------------------------------------------
-- Splitting arguments into source files and object files.  This is where we
-- interpret the -x <suffix> option, and attach a (Maybe Phase) to each source
-- file indicating the phase specified by the -x option in force, if any.

partition_args [] srcs objs = (reverse srcs, reverse objs)
partition_args ("-x":suff:args) srcs objs
  | "none" <- suff  = partition_args args srcs objs
  | StopLn <- phase = partition_args args srcs (slurp ++ objs)
  | otherwise       = partition_args rest (these_srcs ++ srcs) objs
    where phase = startPhase suff
          (slurp,rest) = break (== "-x") args 
          these_srcs = zip slurp (repeat (Just phase))
partition_args (arg:args) srcs objs
  | looks_like_an_input arg = partition_args args ((arg,Nothing):srcs) objs
  | otherwise               = partition_args args srcs (arg:objs)

    {-
      We split out the object files (.o, .dll) and add them
      to v_Ld_inputs for use by the linker.

      The following things should be considered compilation manager inputs:

       - haskell source files (strings ending in .hs, .lhs or other 
         haskellish extension),

       - module names (not forgetting hierarchical module names),

       - and finally we consider everything not containing a '.' to be
         a comp manager input, as shorthand for a .hs or .lhs filename.

      Everything else is considered to be a linker object, and passed
      straight through to the linker.
    -}
looks_like_an_input m =  isSourceFilename m 
              || looksLikeModuleName m
              || '.' `notElem` m

{-
-- I copied this from GHC's InteractiveUI/reloadModule to see if it would
-- fix the problem, but it didn't 
revertCAFs :: IO ()
revertCAFs = do
  rts_revertCAFs
  --turnOffBuffering
    -- Have to turn off buffering again, because we just 
    -- reverted stdout, stderr & stdin to their defaults.

foreign import ccall "revertCAFs" rts_revertCAFs  :: IO ()  
    -- Make it "safe", just in case
-}