{-# OPTIONS -cpp -#include "windows.h" #-}
-- ----------------------------------------------------------------------------
-- |
-- Module	: GHCParse
-- Author	: Simon Marlow <simonmar@microsoft.com>
-- Copyright    : (c) Microsoft Corporation, All Rights Reserved
-- 
-- Implementation of parseSource using GHC.
--
-- ----------------------------------------------------------------------------

module GHCParse (
#ifdef USING_GHC
	new, done, parseSource, bstrToStringBuffer
#endif
  ) where

#ifdef USING_GHC

-- VS/Haskell stuff
import ProjectState
import ProjectContent
import HaskellState    ( State(..) )
import BabelServiceLib as Babel
                       ( IScope, iidIScope
                       , INames
                       , IDeclarations, iidIDeclarations
                       , IMethods
                       , FindDeclarationResult(..)
                       , IParseSink(..), ParseReason(..), Severity(..)
                       , iconGroupSize
                       , ScopeIconGroup(..)
                       , ScopeIconItem(..)
                       , ScopeIconMisc(..)
                       , errorMessage, getFileName, getHierarchy
                       )
import BabelServiceLibProxy
import HaskellProjectProxy
import FilePath		( splitFilePath )
import VsTypes          ( VSITEMID )
import VsClassView (IVsObjectList)
import ExprSearch

-- GHC stuff
import qualified VsGHC as GHC
import Name             ( getName, nameSrcLoc )
import SrcLoc
import Bag		( mapBagM )
import Outputable hiding (trace)
import StringBuffer
import HscTypes         ( lookupTypeEnv )
import FastString       ( unpackFS )
import PprTyThing

-- COM stuff
import Com 		( coFailWithHR, coFailHR, interfaceNULL, isNullInterface, withQueryInterface, addRef, release )
import ComException	( e_FAIL )
import ComServ
import ComPrim		( ifaceToAddr, bstrLen, checkHR, HRESULT )

-- Libraries
import Data.Array	( Array, bounds, (!), listArray )
import Data.Array.IO.Internals ( IOUArray(..) )
import Data.Array.MArray ( unsafeFreeze, newArray_ )
import Data.Array.Base	 ( UArray(..) )
import Data.Dynamic	 ( fromDynamic )
import Data.Ix           ( inRange, rangeSize )
import Data.Int          ( Int32 )
import Data.IORef
import Data.Maybe        ( fromMaybe, isNothing )
import Data.List        ( sortBy )
import Data.Word
import Distribution.PackageDescription
import Time		( getClockTime )
import Control.Concurrent
import Control.Exception as Exception
import Control.Monad    ( unless )
import System.IO
import Foreign		 ( castPtr )
import Foreign.C.Types   ( CChar )
import Foreign.ForeignPtr
import System.IO.Unsafe
import GHC.IOBase
import GHC.Exts

#ifdef DEBUG_MODE
import Debug.Trace (trace, putTraceMsg)
#else
trace _ f = f
putTraceMsg _ = return ()
#endif

-- -----------------------------------------------------------------------------
-- create new HaskellService instance

new :: IO State
new = trace "new" $ do
  session <- GHC.newDefaultSession
  refDecls <- newIORef interfaceNULL
  return (State session refDecls)

done :: State -> IO ()
done (State _ oldThingsRef) = do
  iOldDecls <- readIORef oldThingsRef
  unless (isNullInterface iOldDecls)
    (release iOldDecls >> return ())
  writeIORef oldThingsRef interfaceNULL

-- -----------------------------------------------------------------------------
-- Parsing/analysing/typechecking source buffers with GHC

withHaskellProject :: IParseSink () -> IO a -> IO a -> (ProjectState -> VSITEMID -> IO a) -> IO a
withHaskellProject sink io1 io2 io3 = do
  handle (\ex -> io1) $ do
    (hier,itemid) <- getHierarchy sink
    res <- withQueryInterface iidIProjectGeneralSettings hier  $ \hsproj -> do
             proj_state <- ComServ.getObjState (ifaceToAddr hsproj)
             kind <- getItemKind itemid (prjContent proj_state)
	     case kind of
               File SetupScript -> io2
               _                -> io3 proj_state itemid
    release hier
    return res

parseSource :: Ptr ()  -- really a BSTR pointer
            -> Maybe (IParseSink ())
            -> ParseReason
            -> Int32
            -> State
            -> IO (IScope ())
parseSource bstr maybe_sink reason reserved state@(State default_session oldThingsRef) =
  ghcHandle "parseSource" $ do
    case reason of
      ReasonCheck -> 
        case maybe_sink of
          Just sink -> do
            putTraceMsg "parseSource(ReasonCheck) -> BEGIN"
            buf <- bstrToStringBuffer bstr
            
            session <- withHaskellProject sink (return default_session)
                                               (return default_session)
                                               (\proj_st itemid -> tryWithMVar (prjGHC proj_st) (return default_session) return)
            fname <- getFileName sink
            needs_pp <- GHC.bufferNeedsPreprocesing session fname buf
            source <- if needs_pp
                        then return Nothing
                        else do time <- getClockTime
                                return (Just (buf,time))

            r <- doParse source sink state
            putTraceMsg "parseSource(ReasonCheck) -> END"
            return r
          Nothing   -> do
	    putTraceMsg "parseSource(ReasonCheck), no sink"
	    return interfaceNULL
      reason -> do
	putTraceMsg ("parseSource(" ++ show reason ++ ")")
	return interfaceNULL

-- Each Haskell Project has one GHC.Session associated with it. In the session are loaded
-- all modules that belongs to this project. There is one global session which is used to
-- parse/typecheck modules which are loaded in Visual Studio but aren't part of any
-- project. The global session always contains only the current edited module and its dependents.
-- The each target id in the project specific session contains the module name, while in the global
-- session is used the file name. The added targets contains the buffer, so that GHC can use the 
-- source in the buffer rather than the file on disk. We also have to supply a ClockTime which 
-- corresponds to the time stamp on the source: so we use the current time.
doParse source sink state@(State default_session oldThingsRef) = do
  putTraceMsg "parseSource(ReasonCheck)"

  -- turn all exceptions into errors in the task list
  handle (\ex ->
	  let 
	      reportException str = do
		  let ex_str = "internal error: " ++ str
		  putTraceMsg ("parseSource: " ++ ex_str)
		  errorMessage "<internal>" 0 0 0 0 Babel.SevFatal ex_str sink
		  return interfaceNULL
	  in
	  case ex of
	    DynException d | Just ghc_ex <- fromDynamic d ->
		reportException (show (ghc_ex::GHC.GhcException))
	    _other ->
		reportException (show ex)
	) $ do

    -- Get the GHC session we're going to use.    
    (ghcModule, session) <- withHaskellProject sink parseIndependentModule parseSetupModule parseProjectModule
    dflags <- GHC.getSessionDynFlags session
    GHC.setSessionDynFlags session dflags{GHC.log_action = log_action}
    result <- GHC.checkModule session ghcModule
    GHC.setSessionDynFlags session dflags
    iOldDecls <- readIORef oldThingsRef
    case result of
      Just checkedModule
	      -> do iDecls <- case GHC.checkedModuleInfo checkedModule of
	                        Just modInfo -> do
	                          iDecls <- createIDeclarations session modInfo
	                          writeIORef oldThingsRef iDecls
	                          unless (isNullInterface iOldDecls)
	                            (release iOldDecls >> return ())
	                          unless (isNullInterface iDecls)
	                            (addRef iDecls >> return ())
	                          withHaskellProject sink (return ()) (return ()) (updateModuleInClassView modInfo)
	                          return iDecls
	                        Nothing -> do
	                          unless (isNullInterface iOldDecls)
  	                            (addRef iOldDecls >> return ())
	                          return iOldDecls
                    newIScope iDecls (Just checkedModule) session
      Nothing -> do unless (isNullInterface iOldDecls)
                      (addRef iOldDecls >> return ())
                    newIScope iOldDecls Nothing session
  where 
    parseIndependentModule = do
      -- Add the target relating to this file in the session and remove all other targets.
      filename <- getFileName sink    
      GHC.setTargets default_session [GHC.Target (GHC.TargetFile filename Nothing) source]

      -- try to find which module our file corresponds to.  This is totally
      -- wrong, to put it bluntly.  But it'll work as long as we have the
      -- restriction that filenames follow module names in VS.
      let (_,mod,_) = splitFilePath filename
          ghcModule = GHC.mkModuleName mod
      return (ghcModule,default_session)

    parseSetupModule = do
      -- Add the target relating to this file in the session and remove all other targets.
      filename <- getFileName sink
      GHC.setTargets default_session [GHC.Target (GHC.TargetFile filename Nothing) source]
      return (GHC.mkModuleName "Main",default_session)

    parseProjectModule proj_st itemid = tryWithMVar (prjGHC proj_st) (coFailWithHR e_FAIL "doParse: project's session is unavailable") $ \session -> do
      -- Update the target relating to this file in the session.
      -- We remove the old target, and add a new one containing the buffer,
      -- so that GHC can use the source in the buffer rather than the file
      -- on disk.  We also have to supply a ClockTime which corresponds to
      -- the time stamp on the source: so we use the current time.
      mb_mdl <- getItemGHCModule itemid (prjContent proj_st)
      case mb_mdl of
        Just mdl -> do
          let targetid  = GHC.TargetModule mdl
          GHC.removeTarget session targetid
          GHC.addTarget session (GHC.Target targetid source)
          return (mdl,session)
        Nothing -> parseIndependentModule

    updateModuleInClassView mdlInfo proj_st itemid = setItemTyThings itemid mdlInfo (prjContent proj_st)
	
    createIDeclarations session modInfo = do
      scopeThings <- collect [] (fromMaybe [] (GHC.modInfoTopLevelScope modInfo))
      let unqual = fromMaybe alwaysQualify (GHC.modInfoPrintUnqualified modInfo)
      let dstate = Decls (listArray (0,fromIntegral (length scopeThings)-1) scopeThings) unqual
      createComInstance "<no dll>" dstate (putTraceMsg "RELEASE IDeclarations") ifaces_IDeclarations iidIDeclarations
      where
        collect pairs [] = return (map snd (sortBy cmpPair pairs))
        collect pairs (name:names) = do
          mb_things <- GHC.modInfoLookupName session modInfo name
          case mb_things of
            Just thing -> collect ((showSDocUnqual (ppr name),thing):pairs) names
            Nothing    -> collect pairs names

        cmpPair (x,_) (y,_) = compare x y

    log_action ghcSeverity span style msg = do
      putTraceMsg ("parseSource: " ++ string)
      case ghcSeverity of
        GHC.SevInfo    -> return ()
        GHC.SevWarning -> logit SevWarning
	GHC.SevError   -> logit SevError
        GHC.SevFatal   -> logit SevFatal
      where
        string     = show (msg style)
        
        -- subtract 1 from line nos.: VS starts counting at zero
        sloc  = srcSpanStart span
        sline = fromIntegral (srcLocLine   sloc) - 1
        scol  = fromIntegral (srcLocCol    sloc)
       
        eloc  = srcSpanEnd   span
        eline = fromIntegral (srcLocLine   eloc) - 1
        ecol  = fromIntegral (srcLocCol    eloc)

        logit severity
          | isGoodSrcSpan span = do
              let filePath = unpackFS (srcSpanFile span)
                  ecol' | scol == ecol = scol+1
                        | otherwise    = ecol
              errorMessage filePath sline eline scol ecol' severity string sink
          | otherwise = do
              filename <- getFileName sink
              errorMessage filename 0 0 0 0 severity string sink

instance Show ParseReason where
   showsPrec _ r = showString (showParseReason r)

showParseReason	ReasonColorize		= "ReasonColorize"
showParseReason	ReasonCheck		= "ReasonCheck"
showParseReason	ReasonMemberSelect	= "ReasonMemberSelect"
showParseReason	ReasonCompleteWord	= "ReasonCompleteWord"
showParseReason	ReasonQuickInfo		= "ReasonQuickInfo"
showParseReason	ReasonMethodTip		= "ReasonMethodTip"
showParseReason	ReasonMatchBraces	= "ReasonMatchBraces"
showParseReason	ReasonHighlightBraces	= "ReasonHighlightBraces"
showParseReason	ReasonAutos		= "ReasonAutos"
showParseReason	ReasonCodeSpan		= "ReasonCodeSpan"

-- -----------------------------------------------------------------------------
-- The IScope object

data IScopeState = IScopeState (IDeclarations ()) (Maybe GHC.CheckedModule) GHC.Session

newIScope :: IDeclarations () -> Maybe GHC.CheckedModule -> GHC.Session -> IO (IScope ())
newIScope iDecls mb_checkedModule session =
  createComInstance "<no dll>" istate (releaseIScope istate) ifaces_IScope iidIScope
  where istate = IScopeState iDecls mb_checkedModule session

releaseIScope :: IScopeState -> IO ()
releaseIScope (IScopeState iDecls _ _) = do
  unless (isNullInterface iDecls) $
    release iDecls >> return ()
  return ()

iScope_vtbl :: ComVTable (IScope ()) IScopeState
iScope_vtbl =
  unsafePerformIO (mkIScope_vtbl getDeclarations getDeclarationOfNameAt getDataTipText getMethods narrow)

ifaces_IScope :: [ComInterface IScopeState]
ifaces_IScope = [ComServ.mkDualIface Nothing iidIScope iScope_vtbl]

getDeclarations :: Int32 -> Int32 -> Maybe (INames ()) -> IScopeState -> IO (IDeclarations ())
getDeclarations line idx maybe_names (IScopeState iDecls _ _)
  | isNullInterface iDecls = trace "getDeclarations fail" $ coFailWithHR e_FAIL "No iface"
  | otherwise              = trace "getDeclarations ok" $ do
      addRef iDecls
      return iDecls

getDeclarationOfNameAt :: Int32 -> Int32 -> IScopeState -> IO (FindDeclarationResult,Int32,Int32,String)
getDeclarationOfNameAt y x (IScopeState _ (Just checkedModule) session) = do
  let srcLoc = 
        case findExprInCheckedModule (y+1) x checkedModule of
          FoundName name -> nameSrcLoc name
          FoundId   id   -> nameSrcLoc (getName id)
          _              -> noSrcLoc
  if isGoodSrcLoc srcLoc
    then return (FINDDECL_DeclFound, fromIntegral (srcLocLine srcLoc-1), fromIntegral (srcLocCol srcLoc), unpackFS (srcLocFile srcLoc))
    else return (FINDDECL_DeclNotFound, 0, 0, "")
getDeclarationOfNameAt y x (IScopeState _ Nothing session) = do
  return (FINDDECL_DeclNotFound, 0, 0, "")

getDataTipText :: Int32 -> Int32 -> Int32 -> Int32 -> IScopeState -> IO String
getDataTipText sy sx ey ex (IScopeState _ (Just checkedModule) session) = ghcHandle "getDataTipText" $ do
  case findExprInCheckedModule (sy+1) sx checkedModule of
    FoundName name
      | Just unqual <- GHC.modInfoPrintUnqualified modInfo -> do
          putTraceMsg ("foundName: "++showSDocForUser unqual (ppr name))
          mb_tyThing <- GHC.modInfoLookupName session modInfo name
          case mb_tyThing of
            Just tyThing -> return $! showSDocForUser unqual (pprTyThingInContextLoc True tyThing)
            Nothing      -> putTraceMsg "No such TyThing" >> coFailWithHR e_FAIL "No such TyThing"
    FoundId id
      | Just unqual <- GHC.modInfoPrintUnqualified modInfo -> do
          putTraceMsg ("foundId: "++showSDocForUser unqual (ppr id))
          return $! showSDocForUser unqual (pprTyThingInContextLoc True (GHC.AnId id))
{-    FoundModule modl -> do
          mb_modInfo <- GHC.getModuleInfo session modl
          case mb_modInfo of
             Just modInfo 
                | Just unqual <- GHC.modInfoPrintUnqualified modInfo -> do
                             putTraceMsg ("foundModule: "++showSDocForUser unqual (ppr modl))
                             return (showSDocForUser unqual (text "module" <+> ppr modl <> parens (vcat (punctuate comma (map ppr (GHC.modInfoExports modInfo))))))
             _            -> putTraceMsg "No ModuleInfo" >> coFailWithHR e_FAIL "No ModuleInfo for this module"
-}
    _              -> putTraceMsg "NotFound" >> coFailWithHR e_FAIL "No identifier at this point"
    where
      Just modInfo = GHC.checkedModuleInfo checkedModule
getDataTipText sy sx ey ex (IScopeState _ Nothing session) = ghcHandle "getDataTipText" $ do
  coFailWithHR e_FAIL "Source not parsed"

getMethods :: Int32 -> Int32 -> Maybe (INames ()) -> IScopeState -> IO (IMethods ())
getMethods = error "getMethods"

narrow :: Int32 -> Int32 -> IScopeState -> IO (String, Int32)
narrow line col _ = return ("",line)

-------------------------------------------------------------------------------
-- IDeclarations

data Decls = Decls (Array Int32 GHC.TyThing) PrintUnqualified

getCount :: Decls -> IO Int32
getCount (Decls arr _) = return $! fromIntegral (rangeSize (bounds arr))

getName0 :: Int32 -> Decls -> IO String
getName0 ix (Decls arr unqual) = return $! showSDocForUser unqual (ppr (getName (arr ! ix)))

getDescription :: Int32 -> Decls -> IO String
getDescription ix (Decls arr unqual) = return $! showSDocForUser unqual (pprTyThingInContextLoc True (arr ! ix))

-- ToDo: we could use the "public" icons for exported entities...
getGlyph :: Int32 -> Decls -> IO Int32
getGlyph ix (Decls arr _) = return $!
  case arr ! ix of
    GHC.ATyCon _             -> icon IconGroupType   IconItemNormal
    GHC.ADataCon _           -> icon IconGroupType2  IconItemNormal
    GHC.AnId id
      | GHC.isDictonaryId id -> icon IconGroupType3  IconItemNormal -- ???
      | otherwise            -> icon IconGroupMethod (if GHC.isExportedId id then IconItemPublic else IconItemPrivate)
    GHC.AClass _             -> icon IconGroupClass  IconItemNormal
  where
    icon :: ScopeIconGroup -> ScopeIconItem -> Int32
    icon group status = fromIntegral (fromEnum group) * iconGroupSize 
		      + fromIntegral (fromEnum status)

getBestMatch :: String -> Decls -> IO (Int32, Bool)
getBestMatch str (Decls arr _) =
  return (matchPrefix 0)
  where
    matchPrefix ix
      | inRange (bounds arr) ix = match str (showSDocUnqual (ppr (getName (arr ! ix))))
      | otherwise               = (0, False)
      where
        match []     []     = (ix, True)
        match []     (y:ys) = (ix, False)
        match (x:xs) (y:ys)
          | x == y          = match xs ys
        match _      _      = matchPrefix (ix+1)

iDeclarations_vtbl :: ComVTable (IScope ()) IScopeState
iDeclarations_vtbl =
  unsafePerformIO (mkIDeclarations_vtbl getCount getName0 getDescription getGlyph getBestMatch)

ifaces_IDeclarations :: [ComInterface Decls]
ifaces_IDeclarations 
  = [ComServ.mkDualIface Nothing iidIDeclarations iDeclarations_vtbl]

-- ----------------------------------------------------------------------------
-- StringBuffer operations

-- Grundgy bit of code to convert a BSTR into a StringBuffer that we can parse.

bstrToStringBuffer :: Ptr () -> IO StringBuffer
bstrToStringBuffer bstr = do
  fptr <- mallocForeignPtrBytes (len+1)
  withForeignPtr fptr (bstrToStringLen bstr (fromIntegral len))
  return (StringBuffer fptr len 0)
  where
    len = fromIntegral (bstrLen (castPtr bstr))

foreign import ccall unsafe "bstrToStringLen" 
  bstrToStringLen :: Ptr () -> Int32 -> Ptr Word8 -> IO HRESULT

-- ----------------------------------------------------------------------------
-- Handle GHC's exceptions

ghcHandle :: String -> IO a -> IO a
ghcHandle func act = 
  catchDyn act $ \dyn -> do
	let ex_str = show (dyn :: GHC.GhcException)
	putTraceMsg (func ++ ": " ++ ex_str)
	coFailHR e_FAIL

-- -----------------------------------------------------------------------------
-- Utils

tryWithMVar :: MVar a -> IO b -> (a -> IO b) -> IO b
tryWithMVar m fail io = 
  block $ do
    mb_a <- tryTakeMVar m
    case mb_a of
	Nothing -> unblock fail
	Just a -> do
	    b <- Exception.catch (unblock (io a))
		  	  (\e -> do putMVar m a; throw e)
	    putMVar m a
	    return b

#endif