module Main (main) where
import System.Console.GetOpt
import System.Process
import System.FilePath
import Data.Maybe
import Data.List
import System.Environment
import System.Exit
import System.IO
import Control.Monad
import GHC 
import DynFlags hiding (Option)
import Outputable
import Bag
import SST
import HscTypes
import Finder
import HeaderInfo
import DriverPipeline
import SrcLoc
import StringBuffer
import Module
import Packages

--------------------------------------------------
-- Option processing

data Options = Options
  { ghcDir     :: Maybe String
  , packages   :: [String]
  , searchPath :: [String]
  , ghcOptions :: [String] }
  deriving (Show, Eq)
  
defaultOptions = Options
  { ghcDir     = Nothing
  , packages   = []
  , searchPath = []
  , ghcOptions = [] }

optionTable =
  [ Option ['G'] ["ghc-dir"]
    (ReqArg (\ d opts -> opts { ghcDir = Just d }) "DIR")
    "The directory of the main GHC package.conf file."
  , Option ['p'] ["package"]
    (ReqArg (\ p opts -> opts { packages = p:packages opts }) "PKG")
    "A package which must be exposed while analyzing the source file." 
  , Option ['i'] ["include-dir"]
    (ReqArg (\ d opts -> opts { searchPath = d:searchPath opts }) "DIR")
    "A directory to search for Haskell modules." 
  , Option ['o'] ["option"]
    (ReqArg (\ o opts -> opts { ghcOptions = o:ghcOptions opts }) "OPT")
    "A command-line option to be given to GHC." ]

guessGHCDir opts@(Options { ghcDir = Just d }) = return opts
guessGHCDir opts@(Options { ghcDir = Nothing }) = do
  -- ugh, until I come up with a better way...
  (_, _, err, ph) <- runInteractiveCommand "ghc -v"
  waitForProcess ph
  cs <- hGetContents err
  let ls = lines cs
  case ls of
    _:l:_ -> do
      let (_, pkgconf) = break (=='/') l
      return $ opts { ghcDir = Just (takeDirectory' pkgconf) }
    _     -> return opts

processOptions argv = do
  pn <- getProgName
  let header = "Usage: " ++ pn ++ " [OPTION...] file"
  opts <- guessGHCDir defaultOptions
  case getOpt Permute optionTable argv of
         (o,n:[],[]) -> return (foldl (flip id) opts o, n)
         (_,_,errs ) -> ioError (userError (concat errs ++ usageInfo header optionTable))

--------------------------------------------------
-- Dump Source Span/Type information

dumpSSTs session mod = do
  usermod   <- findModule session mod Nothing
  mbchecked <- checkModule session mod True
  case mbchecked of
    Nothing      -> putStrLn ("Can't find module: "++moduleNameString mod) >> exitFailure
    Just checked -> do
      case typecheckedSource checked of
        Nothing -> putStrLn "Failed to typecheck" >> exitFailure
        Just tychecked -> do
          mbuserModInfo <- getModuleInfo session usermod
          case mbuserModInfo of
            Nothing          -> putStrLn "No module info" >> exitFailure
            Just userModInfo -> do
              let result = concatMap sstLHsBind $ bagToList tychecked
              let shw x = showSDocForUser neverQualify . ppr $ x
              putStr . unlines . map shw . sort . filter knownLoc $ result
              return ()

--------------------------------------------------
-- Get File Summary

data Summary = Summary
  { hiddenPackages  :: [PackageId]
  , modulesNotFound :: [ModuleName]
  , modulesFound    :: [ModuleName]
  , theModuleName   :: ModuleName }
  
getSummary session opts file = do
  withSession session $ \ hsc_env -> do
    let dflags = hsc_dflags hsc_env

    (dflags', hspp_fn) <- preprocess dflags (file, Nothing)
    buf <- hGetStringBuffer hspp_fn
    
    (srcimps,the_imps, L _ mod_name) <- getImports dflags' buf hspp_fn file
    
    (hpkgs, mnfs, mfs) <- foldM (\ (hpkgs, mnfs, mfs) mn  -> do
      fr <- findImportedModule hsc_env mn Nothing
      case fr of
        Found ml m            -> return (hpkgs, mnfs, mn:mfs)
        NoPackage pid         -> return (hpkgs, mnfs, mfs)
        FoundMultiple pids    -> return (hpkgs, mnfs, mfs)
        PackageHidden pid     -> return (pid:hpkgs, mnfs, mfs)
        ModuleHidden pid      -> return (hpkgs, mnfs, mfs)
        NotFound fps mbpid    -> return (hpkgs, mn:mnfs, mfs)
        NotFoundInPackage pid -> return (hpkgs, mnfs, mfs))
      ([], [], [])
      (map unLoc (srcimps ++ the_imps))
      
    return $ Summary 
      { hiddenPackages  = hpkgs
      , modulesFound    = mfs
      , modulesNotFound = mnfs
      , theModuleName   = mod_name }


--------------------------------------------------
-- Main

main = do
  argv         <- getArgs
  (opts, file) <- processOptions argv
  run opts file

run opts file = defaultErrorHandler defaultDynFlags $ do
  session <- newSession $ ghcDir opts
  f0      <- getSessionDynFlags session
  (f1,_)  <- parseDynamicFlags f0 $ 
    (ghcOptions opts) ++
    (map ("-package "++) (packages opts)) ++
    (map ("-i "++) (takeDirectory' file:searchPath opts))
  setSessionDynFlags session f1
  smry   <- getSummary session opts file
  -- expose any "hidden packages" that the summary revealed necessary
  (f2,_) <- parseDynamicFlags f1 $
    (map (("-package "++) . packageIdString) (hiddenPackages smry))
  setSessionDynFlags session f2
  t  <- guessTarget file Nothing
  setTargets session [t]
  sf <- defaultCleanupHandler f2 (load session LoadAllTargets)
  case sf of
    Failed    -> putStrLn "Failed" >> exitFailure
    Succeeded -> do
      dumpSSTs session (theModuleName smry)
      exitWith ExitSuccess

takeDirectory' fn | null dir  = "."
                  | otherwise = dir
  where dir = takeDirectory fn