{-# OPTIONS -cpp -#include windows.h -#include commctrl.h #-} -- ---------------------------------------------------------------------------- -- | -- Module : Project -- Author : Krasimir Angelov -- Copyright : (c) Krasimir Angelov, All Rights Reserved -- -- ---------------------------------------------------------------------------- module Project ( clsidHaskellProject , newHaskellProject ) where import ProjectState import ProjectModuleBrowser import VsTypes import qualified VsProject import VsProject( IVsWindowFrame(..) , IVsProject (..), iidIVsProject , IVsProject2(..), iidIVsProject2 , IVsProject3(..), iidIVsProject3 , IVsHierarchy(..), iidIVsHierarchy , IVsUIHierarchy(..), iidIVsUIHierarchy , IVsHierarchyEvents(..) , IVsHierarchyDeleteHandler, iidIVsHierarchyDeleteHandler , IVsPersistHierarchyItem, iidIVsPersistHierarchyItem , IVsOutputWindowPane(..) , IVsCfg(..), iidIVsCfg , IVsProjectCfg(..), iidIVsProjectCfg , IVsBuildStatusCallback , IVsBuildableProjectCfg,iidIVsBuildableProjectCfg , IVsGetCfgProvider, iidIVsGetCfgProvider , IVsCfgProvider, iidIVsCfgProvider , VSSAVEFLAGS(..) , VSDELETEITEMOPERATION(..) ) import VsProjectProxy import VsClassView ( IVsLiteTreeList, iidIVsLiteTreeList , IVsObjectList, iidIVsObjectList , LIB_CHECKSTATE(..) , LIB_LISTTYPE(..) , LIB_PERSISTTYPE(..) , LIB_LISTFLAGS(..) , LIB_FLAGS(..) , LIB_CATEGORY(..) , LIBCAT_MODIFIERTYPE(..) , LIBCAT_MEMBERTYPE(..) , LIBCAT_MEMBERACCESS(..) , LIBCAT_CLASSTYPE(..) , LIBCAT_CLASSACCESS(..) , LIBCAT_ACTIVEPROJECT(..) , LIBCAT_VISIBILITY(..) , VSOBSEARCHCRITERIA(..) , VSBROWSECONTAINER(..) , VSCOMPONENTSELECTORDATA , VSTREELISTITEMCHANGE(..) , VSTREEITEMCHANGESMASK(..) , VSTREETEXTOPTIONS(..) , VSTREEFLAGS(..) , VSTREEDISPLAYDATA(..) , VSTREEDISPLAYMASK(..) , VSTREEDISPLAYSTATE(..) , VSOBJGOTOSRCTYPE(..) ) import VsClassViewProxy import BabelServiceLib(IBabelProject,iidIBabelProject) import BabelServiceLibProxy import VsSolution(iidIVsSolution, closeSolutionElement) import VsShell(iidIVsPersistDocData, isDocDataDirty, saveDocData) import FpstfmtProxy import DocObjProxy import OCIdlProxy import Wtypes import ServProv import SiteServices import ProjectContent import TemplateGenerator import HaskellPackageTypes import Compiler import HaskellProjectProxy as HPP import FilePath import VsHaskellDlg import AddReferenceDialog -- GHC import qualified VsGHC as GHC import Outputable hiding (fsep,text) import Module import ErrUtils import Bag import UniqFM import Packages hiding (InstalledPackageInfo(..)) import DynFlags -- COM import Com import ComServ import ComException(dISP_E_MEMBERNOTFOUND, e_FAIL, e_UNEXPECTED, e_INVALIDARG, e_NOTIMPL, oLECMDERR_E_NOTSUPPORTED) import Automation hiding (release) import WideString -- Cabal import Distribution.Package import qualified Distribution.InstalledPackageInfo as IP import Distribution.PackageDescription hiding (Library) import Distribution.License as CL import Distribution.Version(showVersionRange, parseVersionRange, withinRange, Dependency(..)) import Distribution.ParseUtils( showToken, showFilePath, showTestedWith , parseTokenQ, parseFilePathQ, parseTestedWithQ , parseExtensionQ , parseOptCommaList) import Distribution.Compiler(CompilerFlavor(..)) -- std libraries import Control.Concurrent import Control.Concurrent.MVar import Control.Exception(handle,throw) import Control.Monad(when, unless) import System.IO.Unsafe(unsafePerformIO) import System.Directory import Data.IORef import Data.Word import Data.Bits((.&.)) import Data.Version(showVersion, parseVersion) import Data.Maybe(maybe, fromJust) import Data.Array import Text.ParserCombinators.ReadP(readP_to_S) import Text.PrettyPrint.HughesPJ(text,render,fsep) import Foreign.Ptr(nullPtr,minusPtr) #ifdef DEBUG_MODE import Debug.Trace (trace, putTraceMsg) #else import qualified Debug.Trace (trace, putTraceMsg) trace _ f = f putTraceMsg _ = return () #endif #include "../../vs_haskell_ui/resource.h" clsidHaskellProject :: CLSID clsidHaskellProject = mkCLSID "{C0AB5119-7A36-4e57-9FD6-C9DBBD6E8BCE}" ----------------------------------------------------------------------------- -- Project ----------------------------------------------------------------------------- newHaskellProject :: (HIMAGELIST,HIMAGELIST) -> SiteServices -> (IVsProject () -> IO ()) -> FilePath -> String -> PackageDescription -> IID (IUnknown a) -> IO (IUnknown a) newHaskellProject imageLists services removeMe location name pkgDescr iidProject = mdo content <- newProjectContent location pkgDescr refParent <- newIORef interfaceNULL refParentID <- newIORef vSITEMID_ROOT ghc_state <- newEmptyMVar guidref <- newIORef Nothing let prjState = ProjectState (castIface proj) imageLists services content name location refParent refParentID guidref comp ghc_state removeMe (compileProject prjState >> return ()) {-forkIO-} -- TODO: compileProject can be in a separated thread but -- with the current RTS it is faster to execute it sequentialy proj <- createComInstance "" prjState (releaseProj prjState) ifaces_HaskellProject iidProject comp <- newCompiler prjState return proj where compileProject st = GHC.vsghcErrorHandler $ do -- create empty GHC session root_binfo <- getProjectContentBuildInfo (prjContent st) srcDirs <- getProjectContentHsSourceDirs location (prjContent st) session <- GHC.newSession location root_binfo ((location `joinFileName` "dist/build/autogen") : srcDirs) configDependencies session (buildDepends pkgDescr) services -- setup target modules updateGHCTargets (prjContent st) session -- compile GHC.vsghcErrorHandler $ GHC.load session GHC.LoadAllTargets -- update class view items dflags <- GHC.getSessionDynFlags session mod_ids <- fmap elems $ getItemAllGHCModules (prjContent st) mapM_ (updateModule session (thisPackage dflags) (prjContent st)) mod_ids -- set project session putMVar (prjGHC st) session where updateModule session pkgId content (itemid,mdl) = do mb_mdlInfo <- GHC.getModuleInfo session (mkModule pkgId mdl) case mb_mdlInfo of Just mdlInfo -> setItemTyThings itemid mdlInfo content Nothing -> return () updateGHCTargets content session = do mod_ids <- fmap elems $ getItemAllGHCModules content GHC.setTargets session (map (\(itemid,mdl) -> GHC.Target (GHC.TargetModule mdl) Nothing) mod_ids) releaseProj st = do release (prjCompiler st) clearProjectContent (prjContent st) isDocumentInProject :: WideString -> ProjectState -> IO (BOOL, VSDOCUMENTPRIORITY, VSITEMID) isDocumentInProject wfile st = do -- ToDo: check for the project file itself. file <- wideToStr wfile maybe_item <- isFileInProject file (prjLocation st) (prjContent st) case maybe_item of Nothing -> do putTraceMsg ("Project->isDocumentInProject(no): " ++ file) return (0, DP_Unsupported, 0) Just itemid -> do putTraceMsg ("Project->isDocumentInProject(yes): " ++ file) return (1, DP_Standard, itemid) getMkDocument :: VSITEMID -> ProjectState -> IO String getMkDocument itemid st = getItemFilePath itemid (prjLocation st) (prjContent st) openItem :: VSITEMID -> GUID -> IUnknown a -> ProjectState -> IO (IVsWindowFrame ()) openItem itemid guid _ st = do fpath <- getItemFilePath itemid (prjLocation st) (prjContent st) withQueryInterface iidIVsUIHierarchy (prjSelf st) $ \uiHier -> openFile fpath uiHier itemid (prjServices st) getItemContext :: VSITEMID -> ProjectState -> IO (IServiceProvider ()) getItemContext itemID st = do return interfaceNULL generateUniqueItemName :: VSITEMID -> WideString -> WideString -> ProjectState -> IO String generateUniqueItemName itemid pwszExt pwszSuggestedRoot st = do ext <- if pwszExt == nullWideString then return "" else wideToStr pwszExt root <- if pwszSuggestedRoot == nullWideString then return "File" else wideToStr pwszSuggestedRoot fpath <- getItemFilePath itemid (prjLocation st) (prjContent st) let genName index = do let fname = root++show index++ext exists <- doesFileExist (fpath `joinFileName` fname) (if exists then genName (index+1) else return fname) if root == "LICENSE" && ext == "" then return root -- we have only one LICENSE file else genName 1 addItem :: VSITEMID -> VSADDITEMOPERATION -> WideString -> [WideString] -> HWND -> ProjectState -> IO VSADDRESULT addItem itemid VSADDITEMOP_OPENFILE _ pwszItems _ st = handle (\ex -> return ADDRESULT_Failure) $ do withQueryInterface iidIVsUIHierarchy (prjSelf st) $ \uiHierarchy -> do mapM_ (\ws -> do itemPath <- wideToStr ws let (_,itemName) = splitFileName itemPath itemid <- addFileItem itemid itemName (prjContent st) destPath <- getItemFilePath itemid (prjLocation st) (prjContent st) unless (itemPath == destPath) (copyFile itemPath destPath) openFile destPath uiHierarchy itemid (prjServices st)) pwszItems withMVar (prjGHC st) $ updateGHCTargets (prjContent st) return ADDRESULT_Success addItem itemid VSADDITEMOP_CLONEFILE pwszItemName [pwszItemPath] _ st = do itemName <- wideToStr pwszItemName tmplPath <- wideToStr pwszItemPath withQueryInterface iidIVsUIHierarchy (prjSelf st) $ \uiHierarchy -> do r <- handle (\ex -> return ADDRESULT_Failure) $ do itemid <- if snd (splitFileName tmplPath) == "LICENSE" then addLicenseFileItem itemid itemName (prjContent st) -- special case for LICENSE file else addFileItem itemid itemName (prjContent st) metaInfo <- getProjectContentMetaInfo (prjContent st) destPath <- getItemFilePath itemid (prjLocation st) (prjContent st) localPath <- getItemFilePath itemid "." (prjContent st) mb_mod <- getItemGHCModule itemid (prjContent st) let modName = case mb_mod of Just mdl -> moduleNameString mdl Nothing -> fst (splitFileExt itemName) generateTemplate localPath modName (prjName st) metaInfo tmplPath destPath openFile destPath uiHierarchy itemid (prjServices st) return ADDRESULT_Success withMVar (prjGHC st) $ updateGHCTargets (prjContent st) return r addItem itemID _ _ _ _ st = coFailWithHR e_FAIL "Unsupported operation" setSite :: IUnknown a -> ProjectState -> IO () setSite pSP st = putTraceMsg "Project->setSite" getSite :: ProjectState -> IO (IServiceProvider ()) getSite st = getServiceProvider (prjServices st) getSite1 :: IID (IUnknown a) -> ProjectState -> IO (IUnknown a) getSite1 iid st = do iProvider <- getServiceProvider (prjServices st) iSite <- queryInterface iid iProvider release iProvider return iSite queryClose :: ProjectState -> IO BOOL queryClose iptr = do putTraceMsg "Project->queryClose" return 1 close0 :: ProjectState -> IO () close0 st = prjRemoveMe st (prjSelf st) getGuidProperty0 :: VSITEMID -> VSHPROPID -> ProjectState -> IO GUID getGuidProperty0 itemid VSHPROPID_TypeGuid st = do putTraceMsg ("Project->getGuidProperty0 VSHPROPID_TypeGuid") return (clsidToGUID clsidHaskellProject) getGuidProperty0 itemid VSHPROPID_ProjectIDGuid st = do if itemid /= vSITEMID_ROOT then do putTraceMsg "not root" coFailHR e_UNEXPECTED else do mb_guid <- readIORef (prjGUID st) case mb_guid of Just guid -> return guid Nothing -> coFailHR e_FAIL -- not set getGuidProperty0 itemid propid st = do putTraceMsg ("Project->getGuidProperty0 " ++ Prelude.show (fromEnum propid)) coFailWithHR dISP_E_MEMBERNOTFOUND "The property is undefined" setGuidProperty0 :: VSITEMID -> VSHPROPID -> GUID -> ProjectState -> IO () setGuidProperty0 itemid VSHPROPID_ProjectIDGuid rguid st = do putTraceMsg ("setGuidProperty(ProjectIDGuid): " ++ guidToString rguid) if itemid /= vSITEMID_ROOT then do putTraceMsg "not root" coFailHR e_UNEXPECTED else do mb_guid <- readIORef (prjGUID st) case mb_guid of Just _ -> coFailHR e_FAIL -- already set Nothing -> writeIORef (prjGUID st) (Just rguid) setGuidProperty0 itemid propid rguid iptr = do putTraceMsg ("Project->setGuidProperty0 " ++ Prelude.show (fromEnum propid)) coFailWithHR dISP_E_MEMBERNOTFOUND "The property is undefined or read only" getProperty0 :: VSITEMID -> VSHPROPID -> VARIANT -> ProjectState -> IO () getProperty0 itemid VSHPROPID_IconImgList var st = inInt (fst (prjImageLists st) `minusPtr` nullPtr) var getProperty0 itemid VSHPROPID_IconIndex var st = do kind <- getItemKind itemid (prjContent st) inInt (case kind of Root -> 0 References -> 1 Folder PlainFolder -> 4 Folder HsSourceFolder -> 6 Folder NPFile -> 15 File ExposedModule -> 8 File HiddenModule -> 9 File CSource -> 11 File HSource -> 12 File SetupScript -> 10 File LicenseText -> 13 File TextFile -> 14 File NPFile -> 17 Package -> 3 Null -> 17) var getProperty0 itemid VSHPROPID_OpenFolderIconIndex var st = do kind <- getItemKind itemid (prjContent st) inInt (case kind of Root -> 0 References -> 2 Folder PlainFolder -> 5 Folder HsSourceFolder -> 7 Folder NPFile -> 16 File ExposedModule -> 8 File HiddenModule -> 9 File CSource -> 11 File HSource -> 12 File SetupScript -> 10 File LicenseText -> 13 File TextFile -> 14 File NPFile -> 17 Package -> 3 Null -> 17) var getProperty0 itemid VSHPROPID_Expandable var st = do kind <- getItemKind itemid (prjContent st) case kind of Root -> inBool True var References -> do childid <- getChildItemID itemid (prjContent st) inBool (childid /= vSITEMID_NIL) var Folder _ -> do childid <- getChildItemID itemid (prjContent st) inBool (childid /= vSITEMID_NIL) var File _ -> inBool False var Package -> inBool False var Null -> inBool False var getProperty0 itemid VSHPROPID_ExpandByDefault var st = do inBool False var getProperty0 itemid VSHPROPID_Caption var st = do caption <- getItemDisplayName itemid (prjContent st) inString caption var getProperty0 itemid VSHPROPID_EditLabel var st = do kind <- getItemKind itemid (prjContent st) caption <- getItemName itemid (prjContent st) case kind of Root -> inString caption var Folder _ -> inString caption var File _ -> inString caption var _ -> coFailWithHR dISP_E_MEMBERNOTFOUND "Undefined property" getProperty0 itemid VSHPROPID_Root var st = do inWord32 vSITEMID_ROOT var getProperty0 itemid VSHPROPID_FirstVisibleChild var st = do childid <- getChildItemID itemid (prjContent st) inWord32 childid var getProperty0 itemid VSHPROPID_FirstChild var st = do childid <- getChildItemID itemid (prjContent st) inWord32 childid var getProperty0 itemid VSHPROPID_NextVisibleSibling var st = do nextid <- getNextItemID itemid (prjContent st) inWord32 nextid var getProperty0 itemid VSHPROPID_NextSibling var st = do nextid <- getNextItemID itemid (prjContent st) inWord32 nextid var getProperty0 itemid VSHPROPID_Parent var st = do parentid <- getParentItemID itemid (prjContent st) inWord32 parentid var getProperty0 itemid VSHPROPID_BrowseObject var st = do kind <- getItemKind itemid (prjContent st) case kind of Root -> withQueryInterface iidIDispatch (prjSelf st) $ \dispatch -> inIDispatch dispatch var File kind -> do let ifaces = case kind of ExposedModule -> ifaces_HaskellModuleItem HiddenModule -> ifaces_HaskellModuleItem _ -> ifaces_HaskellFileItem dispatch <- createComInstance "" (st,itemid) (return ()) ifaces iidIDispatch inIDispatch dispatch var release dispatch return () Folder _ -> do dispatch <- createComInstance "" (st,itemid) (return ()) ifaces_HaskellFolderItem iidIDispatch inIDispatch dispatch var release dispatch return () Package -> do dispatch <- createComInstance "" (st,itemid) (return ()) ifaces_HaskellPackageItem iidIDispatch inIDispatch dispatch var release dispatch return () _ -> coFailWithHR dISP_E_MEMBERNOTFOUND "No property page for this item" getProperty0 itemid VSHPROPID_ProjectName var st = do caption <- getItemName vSITEMID_ROOT (prjContent st) inString caption var getProperty0 itemid VSHPROPID_ProjectDir var st = do inString (prjLocation st) var getProperty0 itemid VSHPROPID_ParentHierarchy var st = do parent <- readIORef (prjParent st) inIUnknown parent var getProperty0 itemid VSHPROPID_ParentHierarchyItemid var st = do parentid <- readIORef (prjParentID st) inInt (fromIntegral parentid) var getProperty0 itemid VSHPROPID_ProjectType var st | itemid == vSITEMID_ROOT = do str <- loadString IDS_PROJECT_TYPE (prjServices st) inString str var | otherwise = do str <- loadString IDS_FILENODE_TYPE (prjServices st) inString str var getProperty0 itemid VSHPROPID_SaveName var st = do filename <- getItemFilePath itemid (prjLocation st) (prjContent st) inString filename var getProperty0 itemid propid var st = do putTraceMsg ("Project->getProperty0 " ++ Prelude.show (fromEnum propid)) coFailWithHR dISP_E_MEMBERNOTFOUND "Undefined property" setProperty0 :: VSITEMID -> VSHPROPID -> VARIANT -> ProjectState -> IO () setProperty0 itemid VSHPROPID_Caption var st = do caption <- resString var setItemName itemid caption (prjContent st) setProperty0 itemid VSHPROPID_EditLabel var st = do newName <- resString var kind <- getItemKind itemid (prjContent st) case kind of Root -> setItemName itemid newName (prjContent st) _ -> renameItem itemid newName st setProperty0 itemid VSHPROPID_ParentHierarchy var st = do parent <- resIUnknown var writeIORef (prjParent st) parent notifyPropertyChanged (prjContent st) itemid VSHPROPID_ParentHierarchy setProperty0 itemid VSHPROPID_ParentHierarchyItemid var st = do parentid <- resInt var writeIORef (prjParentID st) (fromIntegral parentid) notifyPropertyChanged (prjContent st) itemid VSHPROPID_ParentHierarchyItemid setProperty0 itemid propid var iptr = coFailWithHR dISP_E_MEMBERNOTFOUND "The property is undefined or read only" renameItem :: VSITEMID -> String -> ProjectState -> IO () renameItem itemid newName st = do oldName <- getItemName itemid (prjContent st) oldPath <- getItemFilePath itemid (prjLocation st) (prjContent st) setItemName itemid newName (prjContent st) newPath <- getItemFilePath itemid (prjLocation st) (prjContent st) (my_renameFile newName oldPath newPath) `catch` \ex -> do showMessage (show ex) (prjServices st) setItemName itemid oldName (prjContent st) where my_renameFile newName source dest = do kind <- getItemKind itemid (prjContent st) case kind of Folder _ -> renameDirectory source dest File _ -> do renameFile source dest handle (\_ -> renameFile dest source) $ do withQueryInterface iidIVsUIHierarchy (prjSelf st) $ \uiHierarchy -> renameDocFile source dest uiHierarchy itemid (prjServices st) _ -> return () withMVar (prjGHC st) $ updateGHCTargets (prjContent st) getNestedHierarchy :: VSITEMID -> IID (IUnknown i0) -> ProjectState -> IO (IUnknown i0, VSITEMID) getNestedHierarchy itemid iidHierarchyNested iptr = do putTraceMsg "Project->getNestedHierarchy" coFailWithHR dISP_E_MEMBERNOTFOUND "No nested hierarchy" getCanonicalName :: VSITEMID -> ProjectState -> IO String getCanonicalName itemid iptr = do return (show itemid) parseCanonicalName :: WideString -> ProjectState -> IO VSITEMID parseCanonicalName pszName st = do name <- wideToStr pszName return (read name) unused0 :: ProjectState -> IO () unused0 iptr = return () adviseHierarchyEvents :: IVsHierarchyEvents () -> ProjectState -> IO VSCOOKIE adviseHierarchyEvents eventSink st = addHierarchyEventListener eventSink (prjContent st) unadviseHierarchyEvents :: VSCOOKIE -> ProjectState -> IO () unadviseHierarchyEvents cookie st = removeHierarchyEventListener cookie (prjContent st) unused1 :: ProjectState -> IO () unused1 iptr = return () unused2 :: ProjectState -> IO () unused2 iptr = return () unused3 :: ProjectState -> IO () unused3 iptr = return () unused4 :: ProjectState -> IO () unused4 iptr = return () guidVsUIHierarchyWindowCmds :: GUID guidVsUIHierarchyWindowCmds = mkGUID "{60481700-078B-11D1-AAF8-00A0C9055A90}" guidVSStd97Cmds :: GUID guidVSStd97Cmds = mkGUID "{5EFC7975-14BC-11CF-9B2B-00AA00573819}" guidVSStd2K :: GUID guidVSStd2K = mkGUID "{1496A755-94DE-11D0-8C3F-00C04FC2AAE2}" queryStatus :: GUID -> [OLECMD] -> Maybe OLECMDTEXT -> ProjectState -> IO ([OLECMD], Maybe OLECMDTEXT) queryStatus pguidCmdGroup prgCmds@[cmd@(TagOLECMD{cmdID=nCmdID})] pCmdText st = do withQueryInterface iidIVsHierarchy (prjSelf st) $ \hierarchy -> do items <- getCurrentSelection hierarchy (prjServices st) let itemid = case items of [itemid] -> itemid _ -> vSITEMID_ROOT queryStatusCommand itemid pguidCmdGroup prgCmds pCmdText st exec :: GUID -> DWORD -> DWORD -> VARIANT -> VARIANT -> ProjectState -> IO () exec pguidCmdGroup nCmdID nCmdexecopt pvaIn pvaOut st = do withQueryInterface iidIVsHierarchy (prjSelf st) $ \hierarchy -> do items <- getCurrentSelection hierarchy (prjServices st) let itemid = case items of [itemid] -> itemid _ -> vSITEMID_ROOT execCommand itemid pguidCmdGroup nCmdID nCmdexecopt pvaIn pvaOut st queryStatusCommand :: VSITEMID -> GUID -> [OLECMD] -> Maybe OLECMDTEXT -> ProjectState -> IO ([OLECMD], Maybe OLECMDTEXT) queryStatusCommand itemid pguidCmdGroup [cmd@(TagOLECMD{cmdID=nCmdID})] pCmdText st | pguidCmdGroup == guidVSStd97Cmds && nCmdID `elem` [220,244,245] = do kind <- getItemKind itemid (prjContent st) case kind of Root -> return ([cmd{cmdf= 3}],pCmdText) Folder kind -> return ([cmd{cmdf= if kind == NPFile then 17 else 3}],pCmdText) File kind -> return ([cmd{cmdf= if kind == NPFile then 17 else 3}],pCmdText) _ -> return ([cmd{cmdf=17}],pCmdText) | pguidCmdGroup == guidVsUIHierarchyWindowCmds && nCmdID == 1 = -- UIHWCMDID_RightClick return ([cmd{cmdf=3}],pCmdText) | (pguidCmdGroup == guidVsUIHierarchyWindowCmds && (nCmdID == 2 || nCmdID == 3)) || (pguidCmdGroup == guidVSStd97Cmds && nCmdID == 261) = do -- cmdidOpen,UIHWCMDID_DoubleClick,UIHWCMDID_EnterKey kind <- getItemKind itemid (prjContent st) case kind of File _ -> return ([cmd{cmdf= 3}],pCmdText) _ -> return ([cmd{cmdf=17}],pCmdText) | pguidCmdGroup == guidVSStd2K && nCmdID == 1113 = return ([cmd{cmdf=3}],pCmdText) | pguidCmdGroup == guidVSStd2K && nCmdID == 1109 = do -- ECMD_INCLUDEINPROJECT kind <- getItemKind itemid (prjContent st) case kind of Folder kind -> return ([cmd{cmdf= if kind == NPFile then 3 else 17}],pCmdText) File kind -> return ([cmd{cmdf= if kind == NPFile then 3 else 17}],pCmdText) _ -> return ([cmd{cmdf=17}],pCmdText) | pguidCmdGroup == guidVSStd2K && nCmdID == 1110 = do -- ECMD_EXCLUDEFROMPROJECT kind <- getItemKind itemid (prjContent st) case kind of Folder kind -> return ([cmd{cmdf= if kind == NPFile then 17 else 3}],pCmdText) File kind -> return ([cmd{cmdf= if kind == NPFile then 17 else 3}],pCmdText) _ -> return ([cmd{cmdf=17}],pCmdText) | pguidCmdGroup == guidVSStd2K && nCmdID == 600 = do hasNPItems <- getProjectContentHasNonProjItems (prjContent st) return ([cmd{cmdf=if hasNPItems then 7 else 3}],pCmdText) queryStatusCommand itemid pguidCmdGroup prgCmds pCmdText st = coFailWithHR oLECMDERR_E_NOTSUPPORTED "The command is not supported" execCommand :: VSITEMID -> GUID -> DWORD -> DWORD -> VARIANT -> VARIANT -> ProjectState -> IO () execCommand itemid pguidCmdGroup nCmdID nCmdexecopt pvaIn pvaOut st | pguidCmdGroup == guidVsUIHierarchyWindowCmds && nCmdID == 1 = do pos <- getCursorPos kind <- getItemKind itemid (prjContent st) case kind of Root -> showProjNodeContextMenu pos (prjServices st) References -> showReferencesContextMenu pos (prjServices st) Folder _ -> showFolderNodeContextMenu pos (prjServices st) File _ -> showItemNodeContextMenu pos (prjServices st) Package -> showPackageContextMenu pos (prjServices st) Null -> coFailWithHR oLECMDERR_E_NOTSUPPORTED "No menu defined" | (pguidCmdGroup == guidVsUIHierarchyWindowCmds && (nCmdID == 2 || nCmdID == 3)) || (pguidCmdGroup == guidVSStd97Cmds && nCmdID == 261) = do -- cmdidOpen,UIHWCMDID_DoubleClick,UIHWCMDID_EnterKey kind <- getItemKind itemid (prjContent st) case kind of File _ -> do fpath <- getItemFilePath itemid (prjLocation st) (prjContent st) withQueryInterface iidIVsUIHierarchy (prjSelf st) $ \uiHierarchy -> do frame <- openFile fpath uiHierarchy itemid (prjServices st) release frame return () _ -> return () | pguidCmdGroup == guidVSStd2K && nCmdID == 1113 = do session <- readMVar (prjGHC st) openAddReferenceDialog session (prjContent st) (prjServices st) | pguidCmdGroup == guidVSStd97Cmds && nCmdID == 220 = do addNewItemDlg itemid clsidHaskellProject (prjSelf st) (prjServices st) | pguidCmdGroup == guidVSStd97Cmds && nCmdID == 244 = do addExistingItemDlg itemid clsidHaskellProject (prjSelf st) (prjServices st) | pguidCmdGroup == guidVSStd97Cmds && nCmdID == 245 = do fpath <- getItemFilePath itemid (prjLocation st) (prjContent st) newFolderName <- loadString IDS_NEW_FOLDER (prjServices st) let genName index = do let fname = newFolderName++show index exists <- doesDirectoryExist (fpath `joinFileName` fname) (if exists then genName (index+1) else return fname) folderName <- genName 1 handle (\ex -> showMessage (show ex) (prjServices st)) $ createDirectory (fpath++"\\"++folderName) addFolderItem itemid folderName (prjContent st) return () | pguidCmdGroup == guidVSStd2K && nCmdID == 600 = do hasNPItems <- getProjectContentHasNonProjItems (prjContent st) setProjectContentHasNonProjItems (prjLocation st) (not hasNPItems) (prjContent st) | pguidCmdGroup == guidVSStd2K && nCmdID == 1109 = do includeItemInProject itemid (prjContent st) | pguidCmdGroup == guidVSStd2K && nCmdID == 1110 = do excludeItemFromProject itemid (prjContent st) | otherwise = coFailWithHR oLECMDERR_E_NOTSUPPORTED "Not supported" queryDeleteItem :: VSDELETEITEMOPERATION -> VSITEMID -> ProjectState -> IO BOOL queryDeleteItem DELITEMOP_DeleteFromStorage itemid st = do kind <- getItemKind itemid (prjContent st) case kind of Folder _ -> return 1 File _ -> return 1 _ -> return 0 queryDeleteItem DELITEMOP_RemoveFromProject itemid st = do kind <- getItemKind itemid (prjContent st) case kind of Root -> return 1 Package -> return 1 _ -> return 0 deleteItem :: VSDELETEITEMOPERATION -> VSITEMID -> ProjectState -> IO () deleteItem op itemid st = handle (\ex -> showMessage (show ex) (prjServices st)) $ do kind <- getItemKind itemid (prjContent st) -- preprocessing case kind of Root -> do parent <- readIORef (prjParent st) withQueryInterface iidIVsSolution parent $ \solution -> withQueryInterface iidIVsHierarchy (prjSelf st) $ \hierarchy -> closeSolutionElement 1 hierarchy 0 solution Folder _ -> do path <- getItemFilePath itemid (prjLocation st) (prjContent st) removeDirectory path File _ -> do path <- getItemFilePath itemid (prjLocation st) (prjContent st) removeFile path _ -> return () removeItem itemid (prjContent st) -- postprocessing case kind of Package -> withMVar (prjGHC st) $ \session -> do deps <- getProjectContentDependencies (prjContent st) configDependencies session deps (prjServices st) File _ -> withMVar (prjGHC st) $ updateGHCTargets (prjContent st) _ -> return () getClassID :: ProjectState -> IO CLSID getClassID st = return clsidHaskellProject isDirty :: ProjectState -> IO BOOL isDirty st = do isDirty <- getProjectContentIsDirty (prjContent st) return (if isDirty then 1 else 0) initNew :: DWORD -> ProjectState -> IO () initNew _ st = do putTraceMsg "Project->initNew" return () load :: WideString -> DWORD -> BOOL -> ProjectState -> IO () load _ _ _ st = do putTraceMsg "Project->load" return () save :: WideString -> BOOL -> DWORD -> ProjectState -> IO () save _ _ _ st = handle (\ex -> putTraceMsg (show ex) >> throw ex) $ do pkgDescr <- extractPackageDescription (prjContent st) writePackageDescription (prjLocation st `joinFileName` prjName st) pkgDescr saveCompleted :: WideString -> ProjectState -> IO () saveCompleted _ st = do putTraceMsg "Project->saveCompleted" return () getCurFile :: ProjectState -> IO (WideString, DWORD) getCurFile st = do putTraceMsg "Project->getCurFile" res <- stringToWide (prjLocation st `joinFileName` prjName st) return (res, 0) getFormatList :: ProjectState -> IO WideString getFormatList st = do filter <- loadString IDS_HASKELL_PROJECTS_FILTER (prjServices st) stringToWide filter isItemDirty :: VSITEMID -> IUnknown a -> ProjectState -> IO BOOL isItemDirty itemid iptr st = do withQueryInterface iidIVsPersistDocData iptr $ \iPersist -> isDocDataDirty iPersist saveItem :: VSSAVEFLAGS -> LPCOLESTR -> VSITEMID -> IUnknown a0 -> ProjectState -> IO BOOL saveItem flags szOldPath itemid iptr st = withQueryInterface iidIVsPersistDocData iptr $ \iPersist -> do (newFPath,canceled) <- saveDocData flags iPersist unless (canceled /= 0 || null newFPath) $ do oldFPath <- wideToStr szOldPath withQueryInterface iidIVsUIHierarchy (prjSelf st) $ \uiHierarchy -> renameDocFile oldFPath newFPath uiHierarchy itemid (prjServices st) let (_,name,ext) = splitFilePath newFPath newName = name `joinFileExt` ext setItemName itemid newName (prjContent st) withMVar (prjGHC st) $ updateGHCTargets (prjContent st) return canceled getCfgProvider :: ProjectState -> IO (IVsCfgProvider ()) getCfgProvider st = queryInterface iidIVsCfgProvider (prjSelf st) getCfgs :: ULONG -> ProjectState -> IO ([IVsCfg ()], ULONG, DWORD) getCfgs celt st | celt > 0 = do addRef (prjCompiler st) return ([prjCompiler st], 1, 0) | otherwise = return ([], 1, 0) getName :: ProjectState -> IO String getName st = getItemName vSITEMID_ROOT (prjContent st) setName :: String -> ProjectState -> IO () setName name st = setItemName vSITEMID_ROOT name (prjContent st) getVersion :: ProjectState -> IO String getVersion st = do ver <- getItemVersion vSITEMID_ROOT (prjContent st) return (showVersion ver) setVersion :: String -> ProjectState -> IO () setVersion version st = case [ver | (ver,"") <- readP_to_S parseVersion version] of [ver] -> setItemVersion vSITEMID_ROOT ver (prjContent st) _ -> coFailWithHR e_INVALIDARG "Parse error" getLicense :: ProjectState -> IO HPP.License getLicense st = do mi <- getProjectContentMetaInfo (prjContent st) let my_license = case miLicense mi of CL.GPL -> HPP.GPL CL.LGPL -> HPP.LGPL CL.BSD3 -> HPP.BSD3 CL.BSD4 -> HPP.BSD4 CL.PublicDomain -> HPP.PublicDomain CL.AllRightsReserved -> HPP.AllRightsReserved CL.OtherLicense -> HPP.OtherLicense return my_license setLicense :: HPP.License -> ProjectState -> IO () setLicense license st = do mi <- getProjectContentMetaInfo (prjContent st) let cabal_license = case license of HPP.GPL -> CL.GPL HPP.LGPL -> CL.LGPL HPP.BSD3 -> CL.BSD3 HPP.BSD4 -> CL.BSD4 HPP.PublicDomain -> CL.PublicDomain HPP.AllRightsReserved -> CL.AllRightsReserved HPP.OtherLicense -> CL.OtherLicense setProjectContentMetaInfo (prjContent st) (mi{miLicense=cabal_license}) getCopyright :: ProjectState -> IO String getCopyright st = do mi <- getProjectContentMetaInfo (prjContent st) return (miCopyright mi) setCopyright :: String -> ProjectState -> IO () setCopyright copyright st = do mi <- getProjectContentMetaInfo (prjContent st) setProjectContentMetaInfo (prjContent st) (mi{miCopyright=copyright}) getMaintainer :: ProjectState -> IO String getMaintainer st = do mi <- getProjectContentMetaInfo (prjContent st) return (miMaintainer mi) setMaintainer :: String -> ProjectState -> IO () setMaintainer maintainer st = do mi <- getProjectContentMetaInfo (prjContent st) setProjectContentMetaInfo (prjContent st) (mi{miMaintainer=maintainer}) getAuthor :: ProjectState -> IO String getAuthor st = do mi <- getProjectContentMetaInfo (prjContent st) return (miAuthor mi) setAuthor :: String -> ProjectState -> IO () setAuthor author st = do mi <- getProjectContentMetaInfo (prjContent st) setProjectContentMetaInfo (prjContent st) (mi{miAuthor=author}) getStability :: ProjectState -> IO String getStability st = do mi <- getProjectContentMetaInfo (prjContent st) return (miStability mi) setStability :: String -> ProjectState -> IO () setStability stability st = do mi <- getProjectContentMetaInfo (prjContent st) setProjectContentMetaInfo (prjContent st) (mi{miStability=stability}) getHomePage :: ProjectState -> IO String getHomePage st = do mi <- getProjectContentMetaInfo (prjContent st) return (miHomepage mi) setHomePage :: String -> ProjectState -> IO () setHomePage homePage st = do mi <- getProjectContentMetaInfo (prjContent st) setProjectContentMetaInfo (prjContent st) (mi{miHomepage=homePage}) getPackageUrl :: ProjectState -> IO String getPackageUrl st = do mi <- getProjectContentMetaInfo (prjContent st) return (miPkgURL mi) setPackageUrl :: String -> ProjectState -> IO () setPackageUrl pkgURL st = do mi <- getProjectContentMetaInfo (prjContent st) setProjectContentMetaInfo (prjContent st) (mi{miPkgURL=pkgURL}) getSynopsis :: ProjectState -> IO String getSynopsis st = do mi <- getProjectContentMetaInfo (prjContent st) return (miSynopsis mi) setSynopsis :: String -> ProjectState -> IO () setSynopsis synopsis st = do mi <- getProjectContentMetaInfo (prjContent st) setProjectContentMetaInfo (prjContent st) (mi{miSynopsis=synopsis}) getDescription :: ProjectState -> IO String getDescription st = do mi <- getProjectContentMetaInfo (prjContent st) return (miDescription mi) setDescription :: String -> ProjectState -> IO () setDescription description st = do mi <- getProjectContentMetaInfo (prjContent st) setProjectContentMetaInfo (prjContent st) (mi{miDescription=description}) getCategory :: ProjectState -> IO String getCategory st = do mi <- getProjectContentMetaInfo (prjContent st) return (miCategory mi) setCategory :: String -> ProjectState -> IO () setCategory category st = do mi <- getProjectContentMetaInfo (prjContent st) setProjectContentMetaInfo (prjContent st) (mi{miCategory=category}) getTestedWith :: ProjectState -> IO String getTestedWith st = do mi <- getProjectContentMetaInfo (prjContent st) return (showSequence showTestedWith (miTestedWith mi)) setTestedWith :: String -> ProjectState -> IO () setTestedWith testedWith st = do mi <- getProjectContentMetaInfo (prjContent st) case [x | (x,"") <- readP_to_S (parseOptCommaList parseTestedWithQ) testedWith] of [testedWith] -> setProjectContentMetaInfo (prjContent st) (mi{miTestedWith=testedWith}) _ -> coFailWithHR e_INVALIDARG "Parse error" getProjectPath :: ProjectState -> IO String getProjectPath st = do return (prjLocation st `joinFileName` prjName st) getCCOptions :: ProjectState -> IO String getCCOptions st = do binfo <- getProjectContentBuildInfo (prjContent st) return (showSequence showToken (ccOptions binfo)) setCCOptions :: String -> ProjectState -> IO () setCCOptions options st = do binfo <- getProjectContentBuildInfo (prjContent st) case [x | (x,"") <- readP_to_S (parseOptCommaList parseTokenQ) options] of [options] -> setProjectContentBuildInfo (prjContent st) binfo{ccOptions=options} _ -> coFailWithHR e_INVALIDARG "Parse error" getIncludeDirectories :: ProjectState -> IO String getIncludeDirectories st = do binfo <- getProjectContentBuildInfo (prjContent st) return (showSequence showFilePath (includeDirs binfo)) setIncludeDirectories :: String -> ProjectState -> IO () setIncludeDirectories dirs st = do binfo <- getProjectContentBuildInfo (prjContent st) case [x | (x,"") <- readP_to_S (parseOptCommaList parseFilePathQ) dirs] of [dirs] -> setProjectContentBuildInfo (prjContent st) binfo{includeDirs=dirs} _ -> coFailWithHR e_INVALIDARG "Parse error" getIncludes :: ProjectState -> IO String getIncludes st = do binfo <- getProjectContentBuildInfo (prjContent st) return (showSequence showFilePath (includes binfo)) setIncludes :: String -> ProjectState -> IO () setIncludes incs st = do binfo <- getProjectContentBuildInfo (prjContent st) case [x | (x,"") <- readP_to_S (parseOptCommaList parseFilePathQ) incs] of [incs] -> setProjectContentBuildInfo (prjContent st) binfo{includes=incs} _ -> coFailWithHR e_INVALIDARG "Parse error" getGHCOptions :: ProjectState -> IO String getGHCOptions st = do binfo <- getProjectContentBuildInfo (prjContent st) case lookup GHC (options binfo) of Just args -> return (unwords args) Nothing -> return "" setAssoc :: Eq a => a -> b -> [(a,b)] -> [(a,b)] setAssoc k v [] = [(k,v)] setAssoc k v (x:xs) | k == fst x = (k,v):xs | otherwise = x :setAssoc k v xs setGHCOptions :: String -> ProjectState -> IO () setGHCOptions opts st = do binfo <- getProjectContentBuildInfo (prjContent st) setProjectContentBuildInfo (prjContent st) binfo{options = setAssoc GHC (words opts) (options binfo)} getHugsOptions :: ProjectState -> IO String getHugsOptions st = do binfo <- getProjectContentBuildInfo (prjContent st) case lookup Hugs (options binfo) of Just args -> return (unwords args) Nothing -> return "" setHugsOptions :: String -> ProjectState -> IO () setHugsOptions opts st = do binfo <- getProjectContentBuildInfo (prjContent st) setProjectContentBuildInfo (prjContent st) binfo{options = setAssoc Hugs (words opts) (options binfo)} getNHCOptions :: ProjectState -> IO String getNHCOptions st = do binfo <- getProjectContentBuildInfo (prjContent st) case lookup NHC (options binfo) of Just args -> return (unwords args) Nothing -> return "" setNHCOptions :: String -> ProjectState -> IO () setNHCOptions opts st = do binfo <- getProjectContentBuildInfo (prjContent st) setProjectContentBuildInfo (prjContent st) binfo{options = setAssoc NHC (words opts) (options binfo)} getExtensions :: ProjectState -> IO String getExtensions st = do binfo <- getProjectContentBuildInfo (prjContent st) return (showSequence (text . show) (extensions binfo)) setExtensions :: String -> ProjectState -> IO () setExtensions exts st = do binfo <- getProjectContentBuildInfo (prjContent st) case [x | (x,"") <- readP_to_S (parseOptCommaList parseExtensionQ) exts] of [exts] -> setProjectContentBuildInfo (prjContent st) binfo{extensions=exts} _ -> coFailWithHR e_INVALIDARG "Parse error" getLDOptions :: ProjectState -> IO String getLDOptions st = do binfo <- getProjectContentBuildInfo (prjContent st) return (showSequence showToken (ldOptions binfo)) setLDOptions :: String -> ProjectState -> IO () setLDOptions options st = do binfo <- getProjectContentBuildInfo (prjContent st) case [x | (x,"") <- readP_to_S (parseOptCommaList parseTokenQ) options] of [options] -> setProjectContentBuildInfo (prjContent st) binfo{ldOptions=options} _ -> coFailWithHR e_INVALIDARG "Parse error" getLibraries :: ProjectState -> IO String getLibraries st = do binfo <- getProjectContentBuildInfo (prjContent st) return (showSequence showToken (extraLibs binfo)) setLibraries :: String -> ProjectState -> IO () setLibraries libs st = do binfo <- getProjectContentBuildInfo (prjContent st) case [x | (x,"") <- readP_to_S (parseOptCommaList parseTokenQ) libs] of [libs] -> setProjectContentBuildInfo (prjContent st) binfo{extraLibs=libs} _ -> coFailWithHR e_INVALIDARG "Parse error" getLibraryDirectories :: ProjectState -> IO String getLibraryDirectories st = do binfo <- getProjectContentBuildInfo (prjContent st) return (showSequence showFilePath (extraLibDirs binfo)) setLibraryDirectories :: String -> ProjectState -> IO () setLibraryDirectories libDirs st = do binfo <- getProjectContentBuildInfo (prjContent st) case [x | (x,"") <- readP_to_S (parseOptCommaList parseFilePathQ) libDirs] of [libDirs] -> setProjectContentBuildInfo (prjContent st) binfo{extraLibs=libDirs} _ -> coFailWithHR e_INVALIDARG "Parse error" getPages :: ProjectState -> IO CAUUID getPages st = do return (TagCAUUID [ clsidToGUID clsidCCPropertyPage , clsidToGUID clsidHCPropertyPage , clsidToGUID clsidLDPropertyPage ]) getFlags :: ProjectState -> IO VSTREEFLAGS getFlags st = return (VSTREEFLAGSList__ [TF_NOEXPANSION,TF_NORELOCATE,TF_NOINSERTDELETE,TF_NOREALIGN,TF_NOEFFECTS,TF_NOCOLORS]) getItemCount :: ProjectState -> IO ULONG getItemCount st = do mods <- getItemAllGHCModules (prjContent st) return (fromIntegral (rangeSize (bounds mods))) getExpandedList _ _ = coFailWithHR e_NOTIMPL "getExpandedList isn't implemented" locateExpandedList _ _ = coFailWithHR e_NOTIMPL "locateExpandedList isn't implemented" onClose _ = coFailWithHR e_NOTIMPL "onClose isn't implemented" getText :: ULONG -> VSTREETEXTOPTIONS -> ProjectState -> IO WideString getText index tto st = do mod_ids <- getItemAllGHCModules (prjContent st) getItemBrowserWSName (fst (mod_ids ! fromIntegral index)) (prjContent st) getTipText _ _ _ = coFailWithHR e_NOTIMPL "getTipText isn't implemented" getExpandable :: ULONG -> ProjectState -> IO BOOL getExpandable index st = do pmods <- getItemAllGHCModules (prjContent st) return (if rangeSize (bounds pmods) > 0 then 1 else 0) getDisplayData :: ULONG -> ProjectState -> IO VSTREEDISPLAYDATA getDisplayData index st = do mod_ids <- getItemAllGHCModules (prjContent st) fkind <- getItemKind (fst (mod_ids ! fromIntegral index)) (prjContent st) let image | fkind == File ExposedModule = 84 | otherwise = 85 return $! (VSTREEDISPLAYDATA { mask = VSTREEDISPLAYMASKList__ [TDM_IMAGE,TDM_SELECTEDIMAGE] , state = VSTREEDISPLAYSTATEList__ [] , stateMask = VSTREEDISPLAYSTATEList__ [] , image = image , selectedImage = image , hImageList = snd (prjImageLists st) , forceSelectStart = 0 , forceSelectLength = 0 }) updateCounter :: ProjectState -> IO (ULONG, VSTREEITEMCHANGESMASK) updateCounter st = do (counter,change) <- updateModulesCounter (prjContent st) return (counter,grfChange change) getListChanges :: ULONG -> ProjectState -> IO [VSTREELISTITEMCHANGE] getListChanges count st | count /= 1 = coFailWithHR e_UNEXPECTED "Invalid count" | otherwise = do (counter,change) <- updateModulesCounter (prjContent st) return [change] toggleState index st = coFailWithHR e_NOTIMPL "getCapabilities isn't implemented" getCapabilities _ = coFailWithHR e_NOTIMPL "getCapabilities isn't implemented" getList0 :: ULONG -> LIB_LISTTYPE -> LIB_LISTFLAGS -> Maybe VSOBSEARCHCRITERIA -> ProjectState -> IO (IVsObjectList ()) getList0 index LLT_MEMBERS listFlags _ st = do mod_ids <- getItemAllGHCModules (prjContent st) newProjectModuleBrowser (snd (prjImageLists st)) (fst (mod_ids ! (fromIntegral index))) st getList0 _ _ _ _ _ = do coFailWithHR e_UNEXPECTED "Unsupported list type" getCategoryField :: ULONG -> LIB_CATEGORY -> ProjectState -> IO DWORD getCategoryField index LC_LISTTYPE st = return (fromIntegral (fromEnum LLT_MEMBERS)) getCategoryField index _ st = return 0 getExpandable2 _ _ _ = coFailWithHR e_NOTIMPL "getExpandable2 isn't implemented" getNavigationInfo _ _ _ = coFailWithHR e_NOTIMPL "getNavigationInfo isn't implemented" locateNavigationInfo _ _ _ _ = coFailWithHR e_NOTIMPL "locateNavigationInfo isn't implemented" getBrowseObject :: ULONG -> ProjectState -> IO (IDispatch ()) getBrowseObject index st = do mod_ids <- getItemAllGHCModules (prjContent st) var <- allocVARIANT getProperty0 (fst (mod_ids ! fromIntegral index)) VSHPROPID_BrowseObject var st resIDispatch var getUserContext _ _ = coFailWithHR e_NOTIMPL "getUserContext isn't implemented" showHelp _ _ = coFailWithHR e_NOTIMPL "showHelp isn't implemented" getSourceContext _ _ = coFailWithHR e_NOTIMPL "getSourceContext isn't implemented" countSourceItems :: ULONG -> ProjectState -> IO (IVsHierarchy (), VSITEMID, ULONG) countSourceItems index st = do mod_ids <- getItemAllGHCModules (prjContent st) iHier <- queryInterface iidIVsHierarchy (prjSelf st) return (iHier, fst (mod_ids ! fromIntegral index), 1) getMultipleSourceItems _ _ _ _ = coFailWithHR e_NOTIMPL "getMultipleSourceItems isn't implemented" canGoToSource :: ULONG -> VSOBJGOTOSRCTYPE -> ProjectState -> IO BOOL canGoToSource index GS_DEFINITION st = return 1 canGoToSource index _ st = return 0 goToSource :: ULONG -> VSOBJGOTOSRCTYPE -> ProjectState -> IO () goToSource index srcType st = do mod_ids <- getItemAllGHCModules (prjContent st) let (itemid,_) = mod_ids ! (fromIntegral index) fpath <- getItemFilePath itemid (prjLocation st) (prjContent st) withQueryInterface iidIVsUIHierarchy (prjSelf st) $ \uiHier -> openFile fpath uiHier itemid (prjServices st) return () getContextMenu :: ULONG -> ProjectState -> IO (CLSID, LONG, IOleCommandTarget ()) getContextMenu index st = do iCmdTarget <- queryInterface iidIOleCommandTarget (prjSelf st) return (guidSHLMainMenu, idm_VS_CTXT_ITEMNODE, iCmdTarget) where idm_VS_CTXT_ITEMNODE = 0x0430 :: LONG guidSHLMainMenu = mkCLSID "{D309F791-903F-11D0-9EFC-00A0C911004F}" :: CLSID queryDragDrop _ _ _ _ _ = coFailWithHR e_NOTIMPL "queryDragDrop isn't implemented" doDragDrop _ _ _ _ _ = coFailWithHR e_NOTIMPL "doDragDrop isn't implemented" canRename _ _ _ = coFailWithHR e_NOTIMPL "canRename isn't implemented" doRename _ _ _ _ = coFailWithHR e_NOTIMPL "doRename isn't implemented" canDelete _ _ = coFailWithHR e_NOTIMPL "canDelete isn't implemented" doDelete _ _ _ = coFailWithHR e_NOTIMPL "doDelete isn't implemented" fillDescription _ _ _ _ = coFailWithHR e_NOTIMPL "fillDescription isn't implemented" enumClipboardFormats _ _ _ _ = coFailWithHR e_NOTIMPL "enumClipboardFormats isn't implemented" getClipboardFormat _ _ _ _ _ = coFailWithHR e_NOTIMPL "getClipboardFormat isn't implemented" getExtendedClipboardVariant _ _ _ _ = coFailWithHR e_NOTIMPL "getExtendedClipboardVariant isn't implemented" searchFile _ _ = coFailWithHR e_NOTIMPL "searchFile isn't implemented" getObjectBrowserList :: VSITEMID -> ProjectState -> IO (IVsObjectList ()) getObjectBrowserList itemid st = newProjectModuleBrowser (snd (prjImageLists st)) itemid st showSequence showF = render . fsep . map showF iVsProject_vtbl :: ComServ.ComVTable (IVsProject ()) ProjectState iVsProject_vtbl = unsafePerformIO (mkIVsProject_vtbl isDocumentInProject getMkDocument openItem getItemContext generateUniqueItemName addItem) iVsUIHierarchy_vtbl :: ComServ.ComVTable (IVsHierarchy ()) ProjectState iVsUIHierarchy_vtbl = unsafePerformIO (mkIVsUIHierarchy_vtbl setSite getSite queryClose close0 getGuidProperty0 setGuidProperty0 getProperty0 setProperty0 getNestedHierarchy getCanonicalName parseCanonicalName unused0 adviseHierarchyEvents unadviseHierarchyEvents unused1 unused2 unused3 unused4 queryStatusCommand execCommand) iVsHierarchyDeleteHandler_vtbl :: ComServ.ComVTable (IVsHierarchyDeleteHandler ()) ProjectState iVsHierarchyDeleteHandler_vtbl = unsafePerformIO (mkIVsHierarchyDeleteHandler_vtbl queryDeleteItem deleteItem) iPersistFileFormat_vtbl :: ComServ.ComVTable (IVsHierarchy ()) ProjectState iPersistFileFormat_vtbl = unsafePerformIO (mkIPersistFileFormat_vtbl getClassID isDirty initNew load save saveCompleted getCurFile getFormatList) iOleCommandTarget_vtbl :: ComServ.ComVTable (IOleCommandTarget ()) ProjectState iOleCommandTarget_vtbl = unsafePerformIO (mkIOleCommandTarget_vtbl queryStatus exec) iVsPersistHierarchyItem_vtbl :: ComServ.ComVTable (IVsPersistHierarchyItem ()) ProjectState iVsPersistHierarchyItem_vtbl = unsafePerformIO (mkIVsPersistHierarchyItem_vtbl isItemDirty saveItem) iVsGetCfgProvider_vtbl :: ComServ.ComVTable (IVsGetCfgProvider ()) ProjectState iVsGetCfgProvider_vtbl = unsafePerformIO (mkIVsGetCfgProvider_vtbl getCfgProvider) iVsCfgProvider_vtbl :: ComServ.ComVTable (IVsCfgProvider ()) ProjectState iVsCfgProvider_vtbl = unsafePerformIO (mkIVsCfgProvider_vtbl getCfgs) iProjectGeneralSettings_vtbl :: ComServ.ComVTable (IProjectGeneralSettings ()) ProjectState iProjectGeneralSettings_vtbl = unsafePerformIO (mkIProjectGeneralSettings_vtbl getName setName getVersion setVersion getLicense setLicense getCopyright setCopyright getMaintainer setMaintainer getAuthor setAuthor getStability setStability getHomePage setHomePage getPackageUrl setPackageUrl getSynopsis setSynopsis getDescription setDescription getCategory setCategory getTestedWith setTestedWith getProjectPath) iProjectCCSettings_vtbl :: ComServ.ComVTable (IProjectCCSettings ()) ProjectState iProjectCCSettings_vtbl = unsafePerformIO (mkIProjectCCSettings_vtbl getCCOptions setCCOptions getIncludeDirectories setIncludeDirectories getIncludes setIncludes) iProjectHCSettings_vtbl :: ComServ.ComVTable (IProjectHCSettings ()) ProjectState iProjectHCSettings_vtbl = unsafePerformIO (mkIProjectHCSettings_vtbl getGHCOptions setGHCOptions getHugsOptions setHugsOptions getNHCOptions setNHCOptions getExtensions setExtensions) iProjectLDSettings_vtbl :: ComServ.ComVTable (IProjectLDSettings ()) ProjectState iProjectLDSettings_vtbl = unsafePerformIO (mkIProjectLDSettings_vtbl getLDOptions setLDOptions getLibraries setLibraries getLibraryDirectories setLibraryDirectories) iSpecifyPropertyPages_vtbl :: ComServ.ComVTable (ISpecifyPropertyPages ()) ProjectState iSpecifyPropertyPages_vtbl = unsafePerformIO (mkISpecifyPropertyPages_vtbl getPages) iVsObjectList_vtbl :: ComServ.ComVTable (IVsObjectList ()) ProjectState iVsObjectList_vtbl = unsafePerformIO (mkIVsObjectList_vtbl getFlags getItemCount getExpandedList locateExpandedList onClose getText getTipText getExpandable getDisplayData updateCounter getListChanges toggleState getCapabilities getList0 getCategoryField getExpandable2 getNavigationInfo locateNavigationInfo getBrowseObject getUserContext showHelp getSourceContext countSourceItems getMultipleSourceItems canGoToSource goToSource getContextMenu queryDragDrop doDragDrop canRename doRename canDelete doDelete fillDescription enumClipboardFormats getClipboardFormat getExtendedClipboardVariant) iBabelProject_vtbl :: ComServ.ComVTable (IBabelProject ()) ProjectState iBabelProject_vtbl = unsafePerformIO (mkIBabelProject_vtbl searchFile getObjectBrowserList) iObjectWithSite_vtbl :: ComServ.ComVTable (IObjectWithSite ()) ProjectState iObjectWithSite_vtbl = unsafePerformIO (mkIObjectWithSite_vtbl setSite getSite1) ifaces_HaskellProject :: [ComInterface ProjectState] ifaces_HaskellProject = [ ComServ.mkIface iidIVsProject iVsProject_vtbl , ComServ.mkBaseIface iidIVsHierarchy iidIVsUIHierarchy , ComServ.mkIface iidIVsUIHierarchy iVsUIHierarchy_vtbl , ComServ.mkIface iidIVsHierarchyDeleteHandler iVsHierarchyDeleteHandler_vtbl , ComServ.mkIface iidIPersistFileFormat iPersistFileFormat_vtbl , ComServ.mkIface iidIOleCommandTarget iOleCommandTarget_vtbl , ComServ.mkIface iidIVsPersistHierarchyItem iVsPersistHierarchyItem_vtbl , ComServ.mkIface iidIVsGetCfgProvider iVsGetCfgProvider_vtbl , ComServ.mkIface iidIVsCfgProvider iVsCfgProvider_vtbl , ComServ.mkIface iidIProjectGeneralSettings iProjectGeneralSettings_vtbl , ComServ.mkIface iidIProjectCCSettings iProjectCCSettings_vtbl , ComServ.mkIface iidIProjectHCSettings iProjectHCSettings_vtbl , ComServ.mkIface iidIProjectLDSettings iProjectLDSettings_vtbl , ComServ.mkIface iidIDispatch iProjectGeneralSettings_vtbl , ComServ.mkIface iidISpecifyPropertyPages iSpecifyPropertyPages_vtbl , ComServ.mkIface iidIVsLiteTreeList iVsObjectList_vtbl , ComServ.mkIface iidIVsObjectList iVsObjectList_vtbl , ComServ.mkIface iidIBabelProject iBabelProject_vtbl , ComServ.mkIface iidIObjectWithSite iObjectWithSite_vtbl ] ----------------------------------------------------------------------------- -- IHaskellFileItem ----------------------------------------------------------------------------- getName0 :: (ProjectState,VSITEMID) -> IO String getName0 (st,itemid) = do getItemName itemid (prjContent st) setName0 :: String -> (ProjectState,VSITEMID) -> IO () setName0 fileName (st,itemid) = do renameItem itemid fileName st getFilePath0 :: (ProjectState,VSITEMID) -> IO String getFilePath0 (st,itemid) = do getItemFilePath itemid (prjLocation st) (prjContent st) iHaskellFileItem_vtbl :: ComServ.ComVTable (IHaskellFileItem ()) (ProjectState,VSITEMID) iHaskellFileItem_vtbl = unsafePerformIO (mkIHaskellFileItem_vtbl getName0 setName0 getFilePath0) ifaces_HaskellFileItem :: [ComInterface (ProjectState,VSITEMID)] ifaces_HaskellFileItem = [ ComServ.mkIface iidIHaskellFileItem iHaskellFileItem_vtbl , ComServ.mkIface iidIDispatch iHaskellFileItem_vtbl ] ----------------------------------------------------------------------------- -- IHaskellFolderItem ----------------------------------------------------------------------------- getName1 :: (ProjectState,VSITEMID) -> IO String getName1 (st,itemid) = do getItemName itemid (prjContent st) setName1 :: String -> (ProjectState,VSITEMID) -> IO () setName1 fileName (st,itemid) = do renameItem itemid fileName st getSourceDirectory :: (ProjectState,VSITEMID) -> IO YesNo getSourceDirectory (st,itemid) = do kind <- getItemKind itemid (prjContent st) case kind of Folder HsSourceFolder -> return Yes _ -> return No setSourceDirectory :: YesNo -> (ProjectState,VSITEMID) -> IO () setSourceDirectory isSrcDir (st,itemid) = do let fkind = case isSrcDir of Yes -> HsSourceFolder No -> PlainFolder setItemFileKind itemid fkind (prjContent st) srcDirs <- getProjectContentHsSourceDirs (prjLocation st) (prjContent st) withMVar (prjGHC st) $ \session -> do dynFlags <- GHC.getSessionDynFlags session GHC.setSessionDynFlags session dynFlags{GHC.importPaths=(prjLocation st `joinFileName` "dist/build/autogen") : srcDirs} return () getFilePath1 :: (ProjectState,VSITEMID) -> IO String getFilePath1 (st,itemid) = do getItemFilePath itemid (prjLocation st) (prjContent st) iHaskellFolderItem_vtbl :: ComServ.ComVTable (IHaskellFolderItem ()) (ProjectState,VSITEMID) iHaskellFolderItem_vtbl = unsafePerformIO (mkIHaskellFolderItem_vtbl getName1 setName1 getSourceDirectory setSourceDirectory getFilePath1) ifaces_HaskellFolderItem :: [ComInterface (ProjectState,VSITEMID)] ifaces_HaskellFolderItem = [ ComServ.mkIface iidIHaskellFolderItem iHaskellFolderItem_vtbl , ComServ.mkIface iidIDispatch iHaskellFolderItem_vtbl ] ----------------------------------------------------------------------------- -- IHaskellModuleItem ----------------------------------------------------------------------------- getName2 :: (ProjectState,VSITEMID) -> IO String getName2 (st,itemid) = do getItemName itemid (prjContent st) setName2 :: String -> (ProjectState,VSITEMID) -> IO () setName2 fileName (st,itemid) = do renameItem itemid fileName st getModuleName :: (ProjectState,VSITEMID) -> IO String getModuleName (st,itemid) = do mb_mdl <- getItemGHCModule itemid (prjContent st) case mb_mdl of Just mdl -> return $! moduleNameString mdl Nothing -> return "" getExposed :: (ProjectState,VSITEMID) -> IO YesNo getExposed (st,itemid) = do kind <- getItemKind itemid (prjContent st) case kind of File ExposedModule -> return Yes _ -> return No setExposed :: YesNo -> (ProjectState,VSITEMID) -> IO () setExposed exposedState (st,itemid) = do let fkind = case exposedState of Yes -> ExposedModule No -> HiddenModule setItemFileKind itemid fkind (prjContent st) getFilePath2 :: (ProjectState,VSITEMID) -> IO String getFilePath2 (st,itemid) = do getItemFilePath itemid (prjLocation st) (prjContent st) iHaskellModuleItem_vtbl :: ComServ.ComVTable (IHaskellModuleItem ()) (ProjectState,VSITEMID) iHaskellModuleItem_vtbl = unsafePerformIO (mkIHaskellModuleItem_vtbl getName2 setName2 getModuleName getExposed setExposed getFilePath2) ifaces_HaskellModuleItem :: [ComInterface (ProjectState,VSITEMID)] ifaces_HaskellModuleItem = [ ComServ.mkIface iidIHaskellModuleItem iHaskellModuleItem_vtbl , ComServ.mkIface iidIDispatch iHaskellModuleItem_vtbl ] ----------------------------------------------------------------------------- -- IHaskellPackageItem ----------------------------------------------------------------------------- getName3 :: (ProjectState,VSITEMID) -> IO String getName3 (st,itemid) = do getItemName itemid (prjContent st) getVersionRange :: (ProjectState,VSITEMID) -> IO String getVersionRange (st,itemid) = do range <- getItemVersionRange itemid (prjContent st) return (showVersionRange range) setVersionRange :: String -> (ProjectState,VSITEMID) -> IO () setVersionRange range (st,itemid) = do case [x | (x,"") <- readP_to_S parseVersionRange range] of [range] -> do setItemVersionRange itemid range (prjContent st) session <- readMVar (prjGHC st) deps <- getProjectContentDependencies (prjContent st) configDependencies session deps (prjServices st) _ -> coFailWithHR e_INVALIDARG "Parse error" iHaskellPackageItem_vtbl :: ComServ.ComVTable (IHaskellPackageItem ()) (ProjectState,VSITEMID) iHaskellPackageItem_vtbl = unsafePerformIO (mkIHaskellPackageItem_vtbl getName3 getVersionRange setVersionRange) ifaces_HaskellPackageItem :: [ComInterface (ProjectState,VSITEMID)] ifaces_HaskellPackageItem = [ ComServ.mkIface iidIHaskellPackageItem iHaskellPackageItem_vtbl , ComServ.mkIface iidIDispatch iHaskellPackageItem_vtbl ]