{-# LANGUAGE ScopedTypeVariables #-}

module Main(main) where
import Control.Monad
import Data.List
import qualified Data.Map as M
import System.Cmd
import System.Console.GetOpt
import System.Environment
import System.Exit
import System.FilePath

import qualified Language.Core.Core as F
import Language.Core.Check
import Language.Core.Dependencies
import Language.Core.ElimDeadCode 
import Language.Core.Merge
import Language.Core.Prims

import Config -- says where to find GHC (for recompiling Core files)

main :: IO ()
main = do
  args <- getArgs
  case getOpt Permute options args of
    (opts, [fn], _) ->  do
      let pkgRoot = getPkgRootDir opts
      let coreOutFile = getCoreOutFile opts
      let flags = ghcFlags ++ getGhcFlags opts

      recompile pkgRoot fn flags

      let mainFp = replaceExtension fn "hcr"
      deps_ <- getDependencies ((takeDirectory mainFp):pkgRoot) [mainFp]
      let (stuff,modules) = unzip $ filter (notPrim . snd) deps_
      debug 1 $ "Reading " ++ show (length modules) ++ show stuff -- ++ show thisPackage_core_files ++ " and " ++ show stuff

      let single = {-# SCC "MERGING" #-} merge M.empty modules
      let deadKilled@(F.Module mn _ _) = {-# SCC "KILL_DEAD" #-} elimDeadCode False single
      writeFile coreOutFile (show deadKilled)
      when typecheckCore (case checkModule initialEnv deadKilled of
           OkC _ ->
	     do putStrLn $ "Check succeeded! for " ++ show mn
                return ()
	   FailC s -> error ("Typechecking failed: " ++ s))
    _                  -> usageError

options :: [OptDescr Flag]
options = [Option [] ["package-root"] (ReqArg PkgRootDir "DIRECTORY")
              ("Directory d in which to find source code for installed packages;\n"
           ++ "if package foo is installed, I will expect d/foo to contain sources for\n"
           ++ "foo.\n"
           ++ "If you supply more than one package-root, I will search them in order."),
           Option ['o'] ["out"] (ReqArg OutFile "FILEPATH")
              ("Output file for the linked External Core module"),
           Option [] ["ghc-flag"] (ReqArg GhcFlag "GHC FLAG")
              ("Extra flag for GHC")]

getCoreOutFile :: [Flag] -> FilePath
getCoreOutFile fs =
  case find isCoreOutFile fs of
     Just (OutFile outf) -> 
        case splitPath outf of
          [topD,nextDir,_] -> topD </> ((dropTrailingPathSeparator nextDir) `addExtension` ".hcr")
 
          _                  -> outf  
     _   -> error "You must supply a Core output file with -o."

getPkgRootDir :: [Flag] -> [FilePath]
getPkgRootDir fs =
  case pkgRootDirs fs of
      [] -> error "You must provide at least one package root directory with --package-root=/path/to/Core/library/sources." 
      ps -> ps
    where pkgRootDirs :: [Flag] -> [FilePath]
          pkgRootDirs []                     = []
          pkgRootDirs ((PkgRootDir fp):rest) = fp:pkgRootDirs rest
          pkgRootDirs (_:rest)               = pkgRootDirs rest

getGhcFlags :: [Flag] -> [String]
getGhcFlags = foldr (\ a rest -> case a of
  (GhcFlag s) -> s:rest
  _           -> rest) []
 
isCoreOutFile :: Flag -> Bool
isCoreOutFile (OutFile _) = True
isCoreOutFile _           = False

data Flag = PkgRootDir FilePath | OutFile FilePath | GhcFlag String
  deriving Eq

usageError :: a
usageError = error (usageInfo "link" options)

notPrim :: F.Module -> Bool
notPrim (F.Module mn _ _) = mn /= F.primMname && mn /= F.boolMname

debug :: Int -> String -> IO ()
debug n s | n <= dEBUG_LEVEL = putStrLn s
debug _ _ = return ()

dEBUG_LEVEL :: Int
dEBUG_LEVEL = 0

typecheckCore :: Bool
typecheckCore = False

{-
 This is a hack because ghc --make will do nothing when the .o and .hi
 files are up to date but the .hcr file isn't.

 But the user can always supply --ghc-flag=-fforce-recomp if they want
 to be sure to recompile the Core.
-}
recompile :: [FilePath] -> FilePath -> [String] -> IO ()
-- Runs ghc --make -fext-core with the main module and appropriate import dirs
recompile importDirs f flags = do
  let cmd = ghcStr ++ " " ++ mkImportStr importDirs ++ " " ++ "-i" ++ takeDirectory f
         ++ " " ++ f ++ " --make -c -fext-core " ++ intercalate " " flags
  res <- system cmd
  case res of
    ExitSuccess -> return ()
    ExitFailure e -> error ("Compiling to Core failed with error " ++ show e ++ ".\n" ++
                            "Command was: " ++ cmd)

mkImportStr :: [FilePath] -> String
mkImportStr = concatMap (\ s -> "-i" ++ s ++ " ")