{-# OPTIONS -cpp #-} -- ---------------------------------------------------------------------------- -- | -- Module : Compiler -- Author : Krasimir Angelov -- Copyright : (c) Krasimir Angelov, All Rights Reserved -- -- ---------------------------------------------------------------------------- module Compiler ( CompilerState , newCompiler ) where -- VS/Haskell import qualified VsGHC as GHC import ProjectState import VsTypes(VSCOOKIE, vSITEMID_ROOT) import ProjectContent import Wtypes import VsProject hiding (getSite, setSite) import VsProjectProxy import Event import VSConfig import FilePath import SiteServices(showMessage, getServiceProvider) import OCIdlProxy -- Cabal import Distribution.Version import Distribution.Setup import Distribution.Package import Distribution.PackageDescription import Distribution.Simple.Configure import Distribution.Simple.Utils -- COM library import WideString import Com import ComPrim ( coInitializeEx ) import Threads import ComException import ComServ -- libraries #if __GLASGOW_HASKELL__ <= 602 import Process #else import System.Process #endif import System.IO import System.IO.Error hiding (catch,try) import System.IO.Unsafe(unsafePerformIO) import System.Directory (doesFileExist, getModificationTime) import Control.Concurrent import Control.Monad(when,unless) import Foreign import Foreign.C import Data.Maybe import Control.Exception import Prelude hiding ( catch ) import System.Exit ( ExitCode(..) ) import Text.Regex import Data.Char ( isSpace ) import Data.List ( intersperse ) import Debug.Trace -- ---------------------------------------------------------------------------- -- The compiler's state data CompilerState = CompilerState { compEvent :: Event (IVsBuildStatusCallback ()) , compPrj :: ProjectState , compSelf :: IVsCfg () , compBuild :: MVar BuildStatus } compWorkDir comp = prjLocation (compPrj comp) compPrjContent comp = prjContent (compPrj comp) compPrjName comp = prjName (compPrj comp) data BuildStatus = NotBuilding -- No build is in progress | Building -- currently building, (Chan BuildMessage) -- channel to communicate with the builder [IO ()] -- actions to do when the build completes -- ---------------------------------------------------------------------------- -- Making a new IVsBuildableCfg newCompiler :: ProjectState -> IO (IVsCfg ()) newCompiler prjState = mdo event <- newEvent build <- newMVar NotBuilding let compState = CompilerState { compEvent = event, compPrj = prjState, compSelf = comp, compBuild = build } comp <- createComInstance "" compState (releaseCompiler compState) ifaces_Compiler iidIVsCfg return comp -- ---------------------------------------------------------------------------- -- IVsBuildableProjectCfg methods releaseCompiler :: CompilerState -> IO () releaseCompiler comp = do putTraceMsg "releaseCompiler" clearEvent (compEvent comp) return () adviseBuildStatusCallback :: IVsBuildStatusCallback () -> CompilerState -> IO VSCOOKIE adviseBuildStatusCallback callback st = addEventListener (compEvent st) callback unadviseBuildStatusCallback :: VSCOOKIE -> CompilerState -> IO () unadviseBuildStatusCallback cookie st = removeEventListener (compEvent st) cookie startBuild :: IVsOutputWindowPane a0 -> DWORD -> CompilerState -> IO () startBuild pOutputWindowPane v st = do let localBuildInfoPath = compWorkDir st `joinFileName` localBuildInfoFile projectPath = compWorkDir st `joinFileName` compPrjName st lbi_exist <- doesFileExist (compWorkDir st `joinFileName` localBuildInfoFile) uptodate <- if lbi_exist then do lbiTime <- getModificationTime localBuildInfoPath prjTime <- getModificationTime projectPath return (lbiTime > prjTime) else return False doBuild pOutputWindowPane v st (if uptodate then [build_args] else [configure_args,build_args]) where build_args = ["build"] configure_args = [ "configure","ghc" , "--with-compiler="++ghc_path , "--with-haddock="++haddock_path , "--with-happy="++happy_path , "--with-alex="++alex_path ] ghc_path = vshaskellRoot `joinFileName` "bin/ghc.exe" haddock_path = vshaskellRoot `joinFileName` "bin/haddock.exe" happy_path = vshaskellRoot `joinFileName` "bin/happy.exe" alex_path = vshaskellRoot `joinFileName` "bin/alex.exe" startClean :: IVsOutputWindowPane a0 -> DWORD -> CompilerState -> IO () startClean pOutputWindowPane v st = doBuild pOutputWindowPane v st [["clean"]] startUpToDateCheck :: IVsOutputWindowPane a0 -> DWORD -> CompilerState -> IO () startUpToDateCheck _ _ _ = do putTraceMsg "startUpToDateCheck" coFailHR e_NOTIMPL queryStatus0 :: CompilerState -> IO BOOL queryStatus0 st = withMVar (compBuild st) $ \ status -> case status of Building _ _ -> return 1 _ -> return 0 stop :: BOOL -> CompilerState -> IO () stop 0 st = do -- asynchronous stop withMVar (compBuild st) $ \status -> case status of Building chan ios -> writeChan chan BuildStop _ -> return () stop _ st = do -- synchronous stop wait <- newEmptyMVar modifyMVar_ (compBuild st) $ \status -> case status of Building chan ios -> do writeChan chan BuildStop return (Building chan (takeMVar wait : ios)) _ -> return status takeMVar wait wait :: DWORD -> BOOL -> CompilerState -> IO () wait _ _ _ = do putTraceMsg "wait" coFailHR e_NOTIMPL queryStartBuild :: DWORD -> CompilerState -> IO (BOOL, BOOL) queryStartBuild dwOptions st = do putTraceMsg "queryStartBuild" return (1,1) queryStartClean :: DWORD -> CompilerState -> IO (BOOL, BOOL) queryStartClean dwOptions st = do putTraceMsg "queryStartClean" return (1,1) queryStartUpToDateCheck :: DWORD -> CompilerState -> IO (BOOL, BOOL) queryStartUpToDateCheck dwOptions st = do putTraceMsg "queryStartUpToDateCheck" return (0,0) get_DisplayName :: CompilerState -> IO String get_DisplayName st = return "Debug" get_IsDebugOnly :: CompilerState -> IO BOOL get_IsDebugOnly st = return 1 get_IsReleaseOnly :: CompilerState -> IO BOOL get_IsReleaseOnly st = return 0 enumOutputs _ = error "enumOutputs" openOutput _ _ = error "openOutput" get_ProjectCfgProvider st = do queryInterface iidIUnknown (prjSelf (compPrj st)) get_BuildableProjectCfg :: CompilerState -> IO (IVsBuildableProjectCfg ()) get_BuildableProjectCfg st = queryInterface iidIVsBuildableProjectCfg (compSelf st) get_CanonicalName _ = error "get_CanonicalName" get_Platform _ = error "get_Platform" get_IsPackaged _ = error "get_IsPackaged" get_IsSpecifyingOutputSupported _ = error "get_IsSpecifyingOutputSupported" get_TargetCodePage _ = error "get_TargetCodePage" get_UpdateSequenceNumber _ = coFailHR e_NOTIMPL -- what the sample does get_RootURL _ = error "get_RootURL" get_ProjectCfg :: CompilerState -> IO (IVsProjectCfg ()) get_ProjectCfg st = queryInterface iidIVsProjectCfg (compSelf st) debugLaunch :: VSDBGLAUNCHFLAGS -> CompilerState -> IO () debugLaunch flags st = do exeName <- getItemName vSITEMID_ROOT (prjContent (compPrj st)) let prjLoc = prjLocation (compPrj st) targetDir = "dist" `joinFileName` "build" `joinFileName` exeName exePath = prjLoc `joinFileName` targetDir `joinFileName` exeName handle (\ex -> showMessage (Prelude.show ex) (prjServices (compPrj st))) $ do runProcess exePath [] (Just prjLoc) Nothing Nothing Nothing Nothing return () queryDebugLaunch :: VSDBGLAUNCHFLAGS -> CompilerState -> IO BOOL queryDebugLaunch flags st = do main_is <- getProjectContentMainIs (prjContent (compPrj st)) return (if null main_is then 0 else 1) getPages :: CompilerState -> IO CAUUID getPages st = do return (TagCAUUID [ {- mkGUID "{1CC6EA13-3D1C-43b2-ABC2-ECF2A8B95C1E}" , mkGUID "{ACF763B9-52C8-499f-B2EA-1D590593621F}" , mkGUID "{BC4C26BA-9E25-410e-8028-180D941446C0}" -} ]) setSite :: IUnknown () -> CompilerState -> IO () setSite st iSite = return () getSite :: IID (IUnknown a) -> CompilerState -> IO (IUnknown a) getSite iid st = do iProvider <- getServiceProvider (prjServices (compPrj st)) iSite <- queryInterface iid iProvider release iProvider return iSite iIVsCfg_vtbl :: ComServ.ComVTable (IVsBuildableProjectCfg ()) CompilerState iIVsCfg_vtbl = unsafePerformIO (mkIVsCfg_vtbl get_DisplayName get_IsDebugOnly get_IsReleaseOnly) iVsProjectCfg_vtbl :: ComServ.ComVTable (IVsBuildableProjectCfg ()) CompilerState iVsProjectCfg_vtbl = unsafePerformIO (mkIVsProjectCfg_vtbl get_DisplayName get_IsDebugOnly get_IsReleaseOnly enumOutputs openOutput get_ProjectCfgProvider get_BuildableProjectCfg get_CanonicalName get_Platform get_IsPackaged get_IsSpecifyingOutputSupported get_TargetCodePage get_UpdateSequenceNumber get_RootURL) iVsBuildableProjectCfg_vtbl :: ComServ.ComVTable (IVsBuildableProjectCfg ()) CompilerState iVsBuildableProjectCfg_vtbl = unsafePerformIO (mkIVsBuildableProjectCfg_vtbl get_ProjectCfg adviseBuildStatusCallback unadviseBuildStatusCallback startBuild startClean startUpToDateCheck queryStatus0 stop wait queryStartBuild queryStartClean queryStartUpToDateCheck) iVsDebuggableProjectCfg_vtbl :: ComServ.ComVTable (IVsDebuggableProjectCfg ()) CompilerState iVsDebuggableProjectCfg_vtbl = unsafePerformIO (mkIVsDebuggableProjectCfg_vtbl get_DisplayName get_IsDebugOnly get_IsReleaseOnly enumOutputs openOutput get_ProjectCfgProvider get_BuildableProjectCfg get_CanonicalName get_Platform get_IsPackaged get_IsSpecifyingOutputSupported get_TargetCodePage get_UpdateSequenceNumber get_RootURL debugLaunch queryDebugLaunch) iSpecifyPropertyPages_vtbl :: ComServ.ComVTable (ISpecifyPropertyPages ()) CompilerState iSpecifyPropertyPages_vtbl = unsafePerformIO (mkISpecifyPropertyPages_vtbl getPages) iObjectWithSite_vtbl :: ComServ.ComVTable (IObjectWithSite ()) CompilerState iObjectWithSite_vtbl = unsafePerformIO (mkIObjectWithSite_vtbl setSite getSite) ifaces_Compiler :: [ComInterface CompilerState] ifaces_Compiler = [ ComServ.mkIface iidIVsCfg iIVsCfg_vtbl , ComServ.mkIface iidIVsProjectCfg iVsProjectCfg_vtbl , ComServ.mkIface iidIVsBuildableProjectCfg iVsBuildableProjectCfg_vtbl , ComServ.mkIface iidIVsDebuggableProjectCfg iVsDebuggableProjectCfg_vtbl , ComServ.mkIface iidISpecifyPropertyPages iSpecifyPropertyPages_vtbl , ComServ.mkIface iidIObjectWithSite iObjectWithSite_vtbl ] -- ---------------------------------------------------------------------------- -- Building doBuild pOutputWindowPane v st cmds = do ghcstate <- takeMVar (prjGHC (compPrj st)) -- lock the GHC session for the period of the build, so parsing -- will be disabled. Then reset the session, so new parses -- will pick up the new interface files. modifyMVar_ (compBuild st) $ \ build_state -> case build_state of Building _ _ -> coFailHR vs_E_BUSY NotBuilding -> do marshal_pOutputWindowPane <- marshalInterThreadInterface pOutputWindowPane (castIID iidIVsOutputWindowPane) let marshal i = marshalInterThreadInterface i iidIVsBuildStatusCallback marshal_event <- mapEvent marshal (compEvent st) chan <- newChan forkOS (builderThread st chan cmds marshal_pOutputWindowPane marshal_event) return (Building chan [buildFinished ghcstate st]) -- After the build, re-enable parsing by putting back the ghcstate MVar. buildFinished ghcstate st = do putMVar (prjGHC (compPrj st)) ghcstate runSetupLhs workDir args = do exists <- doesFileExist script_path let ghc_args = [ "-ignore-dot-ghci" , "-e","System.Environment.withProgName "++Prelude.show setupScriptName++ " (System.Environment.withArgs ["++concat (intersperse "," (map Prelude.show args))++"] "++ (if exists then "Main.main" else "Distribution.Simple.defaultMain")++ ")" ]++ (if exists then [setupScriptName] else []) runInteractiveProcess (vshaskellRoot `joinFileName` "bin/ghc.exe") ghc_args (Just workDir) Nothing where script_path = workDir `joinFileName` setupScriptName builderThread st chan cmds marshal_pOutputWindowPane marshal_event = do coInitializeEx nullPtr 0{-==COINIT_MULTITHREADED-} >>= checkHR pOutputWindowPane <- unmarshalInterThreadInterface marshal_pOutputWindowPane event <- mapEvent unmarshalInterThreadInterface marshal_event foreachEventListeners event (buildBegin 1) handle (\ex -> do ws <- stringToWide ("build process failed: " ++ Prelude.show ex) outputString ws pOutputWindowPane freeWString ws foreachEventListeners event (buildEnd 0)) $ do r <- sequenceCommands cmds $ \cmd -> do let runghc_args = "Setup.lhs" : cmd setup_cmdline = concat (intersperse " " runghc_args) putTraceMsg ("builderThread: \""++setup_cmdline++"\" started") -- now run the compiler in a separate process (hStdIn,hStdOut,hStdErr,hProcess) <- runSetupLhs (compWorkDir st) cmd -- and run a loop piping the output from the compiler into the -- output window. hSetBuffering hStdOut NoBuffering hSetBuffering hStdErr NoBuffering forkIO (readerProc chan hStdOut) forkIO (readerProc chan hStdErr) forkIO (waitProc chan hProcess) r <- builderMainLoop chan event (compWorkDir st) pOutputWindowPane hClose hStdIn hClose hStdOut hClose hStdErr putTraceMsg ("builderThread: \""++setup_cmdline++"\" ended") return r flushToTaskList pOutputWindowPane case r of ExitSuccess -> foreachEventListeners event (buildEnd 1) ExitFailure _ -> foreachEventListeners event (buildEnd 0) -- make sure these interfaces are Release()'d in this thread clearEvent event release pOutputWindowPane -- the build has now finished, close the channel and wake up -- any threads that were waiting for the build to complete modifyMVar_ (compBuild st) $ \ status -> do case status of Building _ ios -> sequence_ ios _ -> putTraceMsg "builderThread: not building?" return NotBuilding sequenceCommands :: [[String]] -> ([String] -> IO ExitCode) -> IO ExitCode sequenceCommands [] action = return ExitSuccess sequenceCommands (cmd:cmds) action = do r <- action cmd case r of ExitSuccess -> sequenceCommands cmds action _ -> return r builderMainLoop chan event dir pOutputWindowPane = loop 0 ExitSuccess where -- status starts at zero, and increments each time either -- a reader process gets EOF, or the build proc exits. We wait -- for all of these to happen (status==3). -- ToDo: we should really have a contingency plan in case any of -- the threads dies, such as a timeout. loop 3 exitcode = return exitcode loop status exitcode = do msg <- readChan chan foreachEventListeners event (tick 1) case msg of BuildStop -> return (ExitFailure 1) BuildMsg msg -> do ws <- stringToWide (msg++"\n") outputString ws pOutputWindowPane freeWString ws loop status exitcode BuildProcExit code -> loop (status+1) code BuildError file lineno msg' fullmsg' -> do let fullmsg = unlines (reverse fullmsg') msg = unlines (reverse msg') let priority | take 8 (dropWhile isSpace msg) == "Warning:" = TP_NORMAL | otherwise = TP_HIGH wfull <- stringToWide fullmsg wmsg <- stringToWide msg wcat <- stringToWide "" wfile <- stringToWide (mkAbsFilename dir file) outputTaskItemString wfull priority -- priority CAT_BUILDCOMPILE -- category wcat -- subcategory BMP_COMPILE -- bitmap wfile -- filename (fromIntegral (lineno-1)) -- line number wmsg -- task string pOutputWindowPane freeWString wfile freeWString wcat freeWString wmsg freeWString wfull flushToTaskList pOutputWindowPane loop status exitcode EOF -> loop (status+1) exitcode mkAbsFilename dir fn = dir ++ '\\':map (\c -> if c == '/' then '\\' else c) fn waitProc chan hProcess = handle (\e -> writeChan chan (BuildProcExit (ExitFailure 1))) $ do -- ToDo: display error somehow code <- waitForProcess hProcess writeChan chan (BuildProcExit code) readerProc chan hdl = loop Nothing `catch` \e -> writeChan chan EOF -- ToDo: check errors more carefully where loop in_err = do l <- hGetLine hdl `catch` \e -> do case in_err of Just err -> writeChan chan err Nothing -> return () throwIO e case in_err of Just err@(BuildError file lineno msg full) | leading_whitespace l -> loop (Just (BuildError file lineno (l:msg) (l:full))) | otherwise -> do writeChan chan err checkError l Nothing -> checkError l checkError l = case matchRegex errRegex l of Nothing -> do writeChan chan (BuildMsg l) loop Nothing Just (file:lineno:colno:msg:_) -> loop (Just (BuildError file (read lineno::Int) [msg] [file++"("++mkLineCol lineno colno++"):"++msg])) -- put the error message in a format -- that VS understands, even though -- we've already parsed it. Sigh. where mkLineCol lineno "" = lineno mkLineCol lineno colno = lineno++","++init colno leading_whitespace [] = False leading_whitespace (x:_) = isSpace x errRegex = mkRegex "^([^:]*):([0-9]+):([0-9]+:)?(.*)" data BuildMessage = BuildMsg String | BuildError FilePath Int{-line no.-} [String] [String] | BuildProcExit ExitCode | BuildStop | EOF -- ---------------------------------------------------------------------------- vs_E_BUSY = mkHRESULT sEVERITY_ERROR fACILITY_ITF 0x200