module VsGHC (
	module GHC,
	newSession, newDefaultSession,
	resetSession,
	vsghcErrorHandler,
	bufferNeedsPreprocesing
  ) where

-- VS/Haskell stuff
import VSConfig		( vshaskellRoot )
import FilePath

-- GHC stuff
import qualified GHC
import GHC		hiding (newSession)
import HscTypes
import Outputable hiding (trace)
import SrcLoc
import StringBuffer
import DriverPhases(Phase(..), startPhase)
import HeaderInfo(getOptions)

-- Library stuff
import Control.Concurrent
import Control.Exception
import Data.List (nub)
import Debug.Trace
import Distribution.Compiler (extensionsToGHCFlag)
import Distribution.Package (PackageIdentifier(..), showPackageId)
import Distribution.PackageDescription
import Distribution.Setup (CompilerFlavor(..))
import Foreign

-- -----------------------------------------------------------------------------


newSession :: FilePath -> BuildInfo -> [FilePath] -> IO Session
newSession location binfo srcDirs = do
  let ext_flags = snd $ extensionsToGHCFlag (extensions binfo)
      args =     ["-I" ++ location `joinFileName` dir | dir <- includeDirs binfo]
              ++ ["-optc" ++ opt | opt <- ccOptions binfo]
              ++ ["-i" ++ srcDir | srcDir <- srcDirs]
              ++ ["-#include \"" ++ inc ++ "\"" | inc <- includes binfo]
              ++ nub (ext_flags ++ hcOptions GHC (options binfo))
              ++ ["-hide-all-packages"]
  session <- GHC.newSession JustTypecheck (Just vshaskellRoot)
  dflags0 <- GHC.getSessionDynFlags session
  (dflags1,_) <- parseDynamicFlags dflags0 args
  GHC.setSessionDynFlags session dflags1{ verbosity=3, hscTarget=HscNothing, log_action = myLogAction }
  return session

newDefaultSession :: IO Session
newDefaultSession = do
  session <- GHC.newSession JustTypecheck (Just vshaskellRoot)
  dflags <- GHC.getSessionDynFlags session
  GHC.setSessionDynFlags session dflags{ verbosity=0, hscTarget=HscNothing, log_action = myLogAction }
  return session

myLogAction severity srcSpan style msg =
  case severity of
    GHC.SevInfo -> putTraceMsg (show (msg style))
    _           -> putTraceMsg (show (hang (ppr srcSpan <> colon) 4 msg style))

resetSession :: Session -> IO ()
resetSession session = do
  -- I think we need to 'load' here
  putTraceMsg "resetSession"  

vsghcErrorHandler :: IO a -> IO (Maybe a)
vsghcErrorHandler inner = 
  -- top-level exception handler: any unrecognised exception is a compiler bug.
  handle (\exception -> do
	   case exception of
		-- an IO exception probably isn't our fault, so don't panic
		IOException _ ->  putTraceMsg (show exception)
		AsyncException StackOverflow ->
			putTraceMsg "stack overflow: use +RTS -K<size> to increase it"
		_other -> putTraceMsg (show (Panic (show exception)))
	   return Nothing
         ) $

  -- all error messages are propagated as exceptions
  (flip catchDyn) (\dyn -> do
  		case dyn of
		     PhaseFailed _ code -> return Nothing
		     Interrupted -> return Nothing
		     _ -> do putTraceMsg (show (dyn :: GhcException))
			     return Nothing
	    ) $
  inner >>= (\r -> return (Just r))

bufferNeedsPreprocesing :: Session -> FilePath -> StringBuffer -> IO Bool
bufferNeedsPreprocesing session src_fn buf = do
  dflags <- getSessionDynFlags session
  let local_opts = map unLoc (getOptions buf src_fn)
  (dflags', errs) <- parseDynamicFlags dflags local_opts
  let (_,src_ext) = splitFileExt src_fn
      needs_preprocessing
        | Unlit _ <- startPhase src_ext = True
        -- note: local_opts is only required if there's no Unlit phase
        | dopt Opt_Cpp dflags'		= True
        | dopt Opt_Pp  dflags'		= True
        | otherwise			= False
  return needs_preprocessing