{-# OPTIONS -cpp -#include "windows.h" #-}
-- ----------------------------------------------------------------------------
-- |
-- Module	: HaskellService
-- Author	: Simon Marlow <simonmar@microsoft.com>
-- Copyright    : (c) Microsoft Corporation, All Rights Reserved
-- 
-- Implementation of the methods of IBabelService, providing services
-- for Haskell source.
--
-- ----------------------------------------------------------------------------

module GenHaskellService (
	State,
  	new, 
	GenHaskellService.init,
	done, 
	parseSource,
	getMethodFormat,
	getCommentFormat,
	getImageList,
	colorCount,
	getColorInfo,
	colorLine, litColorLine,
 ) where

#ifdef USING_GHC
import GHCParse		( new, done, parseSource, bstrToStringBuffer )
import StringBuffer
#else
import HaskellParser
import HaskellSyntax
import HaskellParseMonad
import Com		( unmarshallBSTR )
import VSNETActions
#endif

-- VS plugin stuff
import HaskellState	( State(..) )
import HaskellScanner	( Token(..), scan, alexStartPos, lit_comment )
import BabelServiceLib

-- Com stuff
import Com 		( LCID, coFailHR, coFailWithHR, mkCLSID,
			  interfaceNULL, HRESULT, checkHR )
import ComDll
import ComException 	( e_NOTIMPL )

-- Base Libraries
import System.IO	 ( hFlush, stdout, hPutStrLn, stderr )
import Foreign hiding ( new )
import System.IO.Unsafe	( unsafePerformIO )
import Data.IORef

import GHC.Exts

#ifdef DEBUG_MODE
import Debug.Trace (trace)
#else
trace _ f = f
#endif
-- ----------------------------------------------------------------------------
-- Standard COM boilerplate

#ifndef USING_GHC
new :: IO State
new = trace "new" $ do
  return (State "testing")
#endif

init :: LCID
     -> Int32
     -> State
     -> IO ()
init language reserved obj = 
  trace "init" $ return ()

#ifndef USING_GHC
done :: State -> IO ()
done obj = 
  trace "done" $ return ()
#endif

-- ----------------------------------------------------------------------------
-- Parse and check the whole source file

#ifndef USING_GHC
parseSource :: Ptr ()
            -> Maybe (IParseSink ())
            -> ParseReason
            -> Int32
            -> State
            -> IO (IScope ())

parseSource bstr maybe_sink reason reserved (State hsc_env) = do
  trace ("parseSource: reason: " ++ show reason) $ do
  text <- unmarshallBSTR (castPtr bstr)
  parseResult <- parseModuleWithMode (mkParseMode "<unknown>" maybe_sink reason vsNETactions) text
  parseSpecialComments maybe_sink text
  case parseResult of
    	ParseOk mod -> trace "parseSource: parse OK" $ return interfaceNULL
    	ParseFailed loc end str -> do
	  case maybe_sink of
	    Nothing -> 
		trace "parseSource: error, but no sink" $
		return interfaceNULL
	    Just sink -> do
		trace ("parseSource: error: " ++ show (srcLine loc) 
					++ ", " ++ show (srcColumn loc)) $ do
		errorMessage
			(fromIntegral (srcLine loc-1)) 		-- start line
			(fromIntegral (srcLine end-1))		-- end line
			(fromIntegral (srcColumn loc-1)) 	-- start col
			(fromIntegral (srcColumn end-1))	-- end col
			SevFatal
			str
			sink
		return interfaceNULL

vsNETactions :: IDEActions
vsNETactions = IDEActions {
  	moduleAction = vsNETModuleAction,
  	declarationAction = vsNETDeclarationAction,
  	expressionAction = vsNETExpressionAction,
  	nameAction = vsNETNameAction,
  	parameterAction = vsNETParameterAction,
  	endFunctionAction = vsNETEndFunctionAction,
  	matchingAction = vsNETMatchingAction
}

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"

#endif

-- ----------------------------------------------------------------------------
-- Information about the language syntax

-- Used for method tips. The formatting below produces the best result in the tool tip window.
getMethodFormat :: State -> IO (String, String, String, String, String, Bool)
getMethodFormat obj = 
  trace "getMethodFormat" $
	  return (":: ",   -- parameter start token, like "(" in C
	          " -> ",  -- parameter separator token
	          "",      -- parameter end token
	          "-> ",      -- precedes type
	          "",      -- ends type
	          False)   -- result type comes after the function name

-- called when user comments or uncomments text
getCommentFormat :: State -> IO (String, String, String, Bool)
getCommentFormat obj = 
  trace "getCommentFormat" $
  return ("--", "{-", "-}", False) -- False == multiple lines don't use "--"

-- used only if one wants to use custom icons
getImageList :: State -> IO (Int32, Int32)
getImageList _ =
  trace ("getImageList") $ 
  coFailHR e_NOTIMPL

-- ----------------------------------------------------------------------------
-- Syntax coloring

-- used only if RequestStockColors registry key is set to zero
colorCount :: State
           -> IO ColorClass
colorCount obj = 
  trace "colorCount" $
  coFailHR e_NOTIMPL

-- used only if RequestStockColors registry key is set to zero
getColorInfo :: ColorClass
             -> State
             -> IO (String, String)
getColorInfo index obj = 
  trace "getColorInfo" $
  coFailHR e_NOTIMPL

colorLine :: Ptr ()
          -> Maybe (IColorSink ())
          -> Int32
          -> State
          -> IO Int32
colorLine line maybe_sink state obj = do
 strbuf <- bstrToStringBuffer line
 loop 0 (alexStartPos,strbuf) (fromIntegral state)
 where
   loop index input state = 
      case scan input state of
	(new_input, len, LEOF, new_state) ->
	   -- trace ("colorLine(done): " ++ show state) $
	   return (fromIntegral new_state)
	(new_input, len, LError, new_state) ->
	   trace ("colorLine(ERROR): " ++ show state ++ show line) $
	   return (fromIntegral new_state)
	(new_input, len, tok, new_state) -> do
	   case maybe_sink of
		Just sink -> do
  	   	  colorize index (index + fromIntegral len)
			(fromIntegral (fromEnum (tokenColorClass tok)))
			(tokenCharClass tok)
			(fromIntegral (fromEnum (tokenTriggerClass tok)))
			sink
		Nothing ->
		   return ()
	   loop (index + fromIntegral len) new_input new_state

-- Literate Haskell version
litColorLine line maybe_sink state obj
  = colorLine line maybe_sink lit_state obj
  where lit_state = if state == 0 then fromIntegral lit_comment else state

tokenColorClass LInteger	= ClassNumber
tokenColorClass LFloat		= ClassNumber
tokenColorClass LChar		= ClassString
tokenColorClass LString		= ClassString
tokenColorClass LSpecial	= ClassKeyword
tokenColorClass LReservedId  	= ClassKeyword
tokenColorClass LReservedOp  	= ClassKeyword
tokenColorClass LLineComment	= ClassComment
tokenColorClass LLitComment	= ClassComment
tokenColorClass LNestedComment	= ClassComment
tokenColorClass LVarId		= ClassIdentifier
tokenColorClass LConId		= ClassIdentifier
tokenColorClass LVarSym		= ClassIdentifier
tokenColorClass LConSym		= ClassIdentifier
tokenColorClass _            	= ClassText

tokenCharClass LInteger		= CharLiteral
tokenCharClass LFloat		= CharLiteral
tokenCharClass LChar		= CharDefaultLast
tokenCharClass LString		= CharDefaultLast
tokenCharClass LSpecial		= CharOperator
tokenCharClass LReservedId	= CharKeyword
tokenCharClass LReservedOp   	= CharOperator
tokenCharClass LVarId		= CharIdentifier
tokenCharClass LConId		= CharIdentifier
tokenCharClass LVarSym		= CharIdentifier
tokenCharClass LConSym		= CharIdentifier
tokenCharClass LWhite		= CharWhiteSpace
tokenCharClass LLineComment	= CharLineComment
tokenCharClass LNestedComment	= CharComment
tokenCharClass LLitComment	= CharComment
tokenCharClass _		= CharText


tokenTriggerClass LSpecial	= TriggerMatchBraces -- ToDo: LSpecial is too broad
tokenTriggerClass LReservedId   = TriggerMatchBraces -- ToDo: LReservedId is too broad
tokenTriggerClass LWhite	= TriggerMethodTip
tokenTriggerClass _		= TriggerNone