{-# LANGUAGE NoMonomorphismRestriction, FlexibleContexts #-}
module Main (main) where

import System.Environment
         ( getArgs )
import System.Exit
         ( exitWith, ExitCode(..) )
import System.Console.GetOpt
         ( OptDescr(..), ArgDescr(..), ArgOrder(..), getOpt, usageInfo )
import Control.Monad
         ( when )
import Data.Version
         ( showVersion )

import Paths_hbuild
         ( version )

import Make.Rules.Dyn
import Distribution.ModuleName hiding (main)
import Data.List
import Make.Rule
import Distribution.Simple.Program as Cabal
import Distribution.Simple.Compiler
import Distribution.Text
import Data.Version
import Data.Maybe
import System.Directory
import System.FilePath
import Distribution.Simple.GHC
import Distribution.Verbosity
import Distribution.Simple.PackageIndex
import qualified Data.Map as M
import Distribution.InstalledPackageInfo hiding (exposed)
import qualified Distribution.InstalledPackageInfo as Pkg
import Distribution.Package
import Make.Goal
import Make.Module hiding (get)
import Data.Cache.Dynamic
import Data.Traversable hiding (mapM)
import Make.MakeM
import Make.JobControl
import Control.Applicative 
import Make.Graph
import Control.Monad.Trans
import Control.Monad.State.Strict
import Make.Memo
import Make.Rules.Dyn.Program.Builtin
import Make.Rules.Dyn.Program
import Make.Rules.Dyn.Types
import Data.DynamicC (DynamicC, TargetCxt, Cxt)

dist = "_hbuild"

cachefile = dist </> "cache"

main :: IO ()
main = do
  (opts, args) <- getOpts

  when (null args) (die usageMessage)
  modules <- mapM (\arg -> case simpleParse arg of
                            Just m -> return m
                            Nothing -> error $ "not a module name: " ++ arg) args :: IO [ModuleName]
  putStrLn $ "search path   : " ++ show (optSearchPath opts)
  putStrLn $ "target modules: " ++ show modules
  
  createDirectoryIfMissing True dist
  let imports = Cons defaultProgramUser (Cons defaultVerbosity (Cons (rulesIO ghc dist (optSearchPath opts)) (Cons (mkLib modules) Nil)))
  case optCommand opts of
    Infer -> do
             s <- execExpr opts . runModuleT imports $ (,,) <$> allModules <*> localModules <*> extensions
             (allmods,local,exts) <- fmap (fromMaybe (error "error while chasing dependencies")) (return s)
             let externals = allmods \\ local
             xs <- resolveToPackages externals
             putStr "build-depends: "
             putStrLn . intercalate ", " . map display $ xs
             putStrLn "other-modules: "
             printModules (local \\ modules)
             putStr "extensions: "
             putStrLn . intercalate ", " $ exts
    Build -> execExpr opts (runModuleT imports (traverse (fst . hi) modules)) >>= print


execExpr :: (Eq a) => Options -> 
  WApp (Rule (Pure IO)) (DynamicC TargetCxt) (DynamicC Cxt) a -> 
  IO (Maybe a)
execExpr opts e = do 
  jc <- poolThreadedJC (optThreads opts)
  withCacheFile cachefile $ \cache -> do 
                     flip evalStateT emptyGraph $ do
                          runGoal jc (matchGoal (Match matchIO))
                                      e  cache

printModules :: (Text a, Ord a) => [a] -> IO ()
printModules ms = putStrLn . unlines . map ("    "++) . map display . sort $ ms

resolveToPackages :: [ModuleName] -> IO [PackageId]
resolveToPackages ms = do 
  pc <- configureAllKnownPrograms minBound (addKnownPrograms [Cabal.ghcProgram,Cabal.ghcPkgProgram] emptyProgramConfiguration)
  ix <- getInstalledPackages minBound [GlobalPackageDB, UserPackageDB] pc
  let pkgs = filter Pkg.exposed $ allPackages ix
      -- is installedPackageId correct?
      m = M.fromList [(m, packageId p) | p <- pkgs, m <- exposedModules p]
  return $ nub $ catMaybes $ map (`M.lookup` m) ms 
      
die :: String -> IO a
die msg = putStr msg >> exitWith (ExitFailure 1)

-- GetOpt

data Options = Options {
    optHelp          :: Bool,
    optVersion       :: Bool,
    optSearchPath    :: [FilePath],
    optThreads       :: !Int,
    optCommand       :: !Command
  }

data Command = Infer | Build
defaultOptions :: Options
defaultOptions = Options {
    optHelp          = False,
    optVersion       = False,
    optSearchPath    = ["."],
    optThreads       = 1,
    optCommand       = Infer
  }

getOpts :: IO (Options, [String])
getOpts = do
  args <- getArgs
  case accumOpts $ getOpt RequireOrder optionDescriptions args of
    (opts, _,    _)
      | optHelp opts    -> printHelp
    (opts, args, [])
      | optVersion opts -> printVersion
      | otherwise       -> return (opts, args)
    (_,     _, errs)    -> printErrors errs
  where
    printErrors errs = die (unlines $ errs ++ ["see hbuild --help for useage"])
    printHelp = do
      putStrLn usageMessage
      putStrLn "hbuild is a build tool for Haskell code"
      exitWith ExitSuccess
    printVersion = do
      putStrLn $ "hbuild version "
              ++ showVersion version
      exitWith ExitSuccess
    accumOpts (opts, args, errs) =
      (foldr (flip (.)) id opts defaultOptions, args, errs)

usageMessage :: String
usageMessage = usageInfo usage optionDescriptions
  where usage = "Usage: hbuild [OPTION ...] [MODULE]\n\nOptions:"

optionDescriptions :: [OptDescr (Options -> Options)]
optionDescriptions =
  [ Option ['h'] ["help"]
      (NoArg (\opts -> opts { optHelp = True }))
      "Show this help text"
  , Option ['V'] ["version"]
      (NoArg (\opts -> opts { optVersion = True }))
      "Print version information"
  , Option ['i'] []
      (ReqArg (\dir opts -> opts { optSearchPath = optSearchPath opts ++ [dir] }) "DIR")
      "Sources search path"
  , Option ['j'] []
      (ReqArg (\n opts -> opts { optThreads = read n }) "N")
      "number of concurrent threads"
  ,Option [] ["build"]
      (NoArg (\opts -> opts { optCommand = Build }))
      "Build the modules"
  ,Option [] ["infer"]
    (NoArg (\opts -> opts { optCommand = Infer }))
    "Infer data for a .cabal file"
  ]