module SiteServices ( -- Creation SiteServices , newSiteServices , releaseSiteServices -- IServiceProvider , getServiceProvider -- UI resource management , loadUILibrary , loadString -- Register/Unregister project types , registerProjectType , unregisterProjectType -- Register/Unregister library manager , registerLibraryMgr , unregisterLibraryMgr -- Context menu , showProjNodeContextMenu , showItemNodeContextMenu , showFolderNodeContextMenu , showReferencesContextMenu , showPackageContextMenu -- Messages , showMessage -- AddNewItem & AddExistingItem dialogs , addNewItemDlg , addExistingItemDlg -- Current Selection , getCurrentSelection -- File operations , openFile , renameDocFile ) where import Com import WideString(nullWideString, stringToWide, freeWString) import Automation hiding (release) import Pointer(allocMemory, freeMemory) import Wtypes(HINSTANCE, ULONG, LONG, POINT(..)) import VsTypes(VSCOOKIE, VSITEMID, vSITEMID_NIL, vSITEMID_SELECTION, VSFPROPID(..), VSSLNSAVEOPTIONS(..)) import VsProject(iidIVsHierarchy, IVsHierarchy, IVsProjectFactory, IVsProject, IVsUIHierarchy, IVsWindowFrame, show, setProperty) import VsClassView import ServProv import HaskellPackageTypes(clsidHaskellPackage) import qualified VsShell import qualified Oleipc import qualified VsRegisterProjectTypes import qualified VsSolution import Data.IORef import Data.Bits((.|.)) import Foreign.Ptr import Debug.Trace import Control.Monad(when) import Control.Exception ( try ) import FilePath ------------------------------------------------------------------------------- -- Data type definition & functions for creation/destruction of the services ------------------------------------------------------------------------------- data SiteServices = SiteServices { servProvider :: IServiceProvider () , shell :: VsShell.IVsShell () , uiManager :: Oleipc.IOleComponentUIManager () , regProjServ :: VsRegisterProjectTypes.IVsRegisterProjectTypes () , regLibMgrServ :: VsClassView.IVsObjectManager () , selMonitor :: VsShell.IVsMonitorSelection () , addItemDlg :: VsShell.IVsAddProjectItemDlg () , addItemValues :: IORef (String, String) , openDoc :: VsShell.IVsUIShellOpenDocument () , runningDocs :: VsShell.IVsRunningDocumentTable () , solution :: VsSolution.IVsSolution () } newSiteServices :: IServiceProvider () -> IO SiteServices newSiteServices servProv = do addRef servProv shell <- queryService (iidToGUID VsShell.iidIVsShell) VsShell.iidIVsShell servProv uiManager <- queryService sidIOleComponentUIManager Oleipc.iidIOleComponentUIManager servProv regProjServ <- queryService (iidToGUID VsRegisterProjectTypes.iidIVsRegisterProjectTypes) VsRegisterProjectTypes.iidIVsRegisterProjectTypes servProv regLibMgrServ <- queryService (iidToGUID VsClassView.iidIVsObjectManager) VsClassView.iidIVsObjectManager servProv selMonitor <- queryService (iidToGUID VsShell.iidIVsMonitorSelection) VsShell.iidIVsMonitorSelection servProv addItemDlg <- queryService (iidToGUID VsShell.iidIVsAddProjectItemDlg) VsShell.iidIVsAddProjectItemDlg servProv openDoc <- queryService (iidToGUID VsShell.iidIVsUIShellOpenDocument) VsShell.iidIVsUIShellOpenDocument servProv runningDocs <- queryService (iidToGUID VsShell.iidIVsRunningDocumentTable) VsShell.iidIVsRunningDocumentTable servProv solution <- queryService (iidToGUID VsSolution.iidIVsSolution) VsSolution.iidIVsSolution servProv refValues <- newIORef ("","") return (SiteServices servProv shell uiManager regProjServ regLibMgrServ selMonitor addItemDlg refValues openDoc runningDocs solution) where sidIOleComponentUIManager :: GUID sidIOleComponentUIManager = mkGUID "{5EFC7974-14BC-11CF-9B2B-00AA00573819}" releaseSiteServices :: SiteServices -> IO () releaseSiteServices services = do release (servProvider services) release (shell services) release (uiManager services) release (regProjServ services) release (regLibMgrServ services) release (selMonitor services) release (addItemDlg services) release (openDoc services) release (runningDocs services) release (solution services) return () ------------------------------------------------------------------------------- -- IServiceProvider ------------------------------------------------------------------------------- getServiceProvider :: SiteServices -> IO (IServiceProvider ()) getServiceProvider services = do let provider = servProvider services addRef provider return provider ------------------------------------------------------------------------------- -- UI resource management functions ------------------------------------------------------------------------------- loadUILibrary :: SiteServices -> IO HINSTANCE loadUILibrary services = VsShell.loadUILibrary (clsidToGUID clsidHaskellPackage) 0 (shell services) loadString :: ULONG -> SiteServices -> IO String loadString resId services = VsShell.loadPackageString (clsidToGUID clsidHaskellPackage) resId (shell services) ------------------------------------------------------------------------------- -- Register/Unregister project types ------------------------------------------------------------------------------- registerProjectType :: CLSID -> IVsProjectFactory () -> SiteServices -> IO VSCOOKIE registerProjectType clsid i services = VsRegisterProjectTypes.registerProjectType (clsidToGUID clsid) i (regProjServ services) unregisterProjectType :: VSCOOKIE -> SiteServices -> IO () unregisterProjectType cookie services = VsRegisterProjectTypes.unregisterProjectType cookie (regProjServ services) ------------------------------------------------------------------------------- -- Register/Unregister object library ------------------------------------------------------------------------------- registerLibraryMgr :: CLSID -> IVsLibraryMgr () -> SiteServices -> IO VSCOOKIE registerLibraryMgr clsid i services = VsClassView.registerLibMgr (clsidToGUID clsid) i (regLibMgrServ services) unregisterLibraryMgr :: VSCOOKIE -> SiteServices -> IO () unregisterLibraryMgr mgrCookie services = VsClassView.unregisterLibMgr mgrCookie (regLibMgrServ services) ------------------------------------------------------------------------------- -- Context menu ------------------------------------------------------------------------------- showProjNodeContextMenu :: POINT -> SiteServices -> IO () showProjNodeContextMenu pos services = Oleipc.showContextMenu 0 guidSHLMainMenu idm_VS_CTXT_PROJNODE (pointToPoints pos) Nothing (uiManager services) where idm_VS_CTXT_PROJNODE = 0x402 :: LONG showItemNodeContextMenu :: POINT -> SiteServices -> IO () showItemNodeContextMenu pos services = Oleipc.showContextMenu 0 guidSHLMainMenu idm_VS_CTXT_ITEMNODE (pointToPoints pos) Nothing (uiManager services) where idm_VS_CTXT_ITEMNODE = 0x0430 :: LONG showFolderNodeContextMenu :: POINT -> SiteServices -> IO () showFolderNodeContextMenu pos services = Oleipc.showContextMenu 0 guidSHLMainMenu idm_VS_CTXT_FOLDERNODE (pointToPoints pos) Nothing (uiManager services) where idm_VS_CTXT_FOLDERNODE = 0x0431 :: LONG showReferencesContextMenu :: POINT -> SiteServices -> IO () showReferencesContextMenu pos services = Oleipc.showContextMenu 0 guidSHLMainMenu idm_VS_CTXT_REFERENCEROOT (pointToPoints pos) Nothing (uiManager services) where idm_VS_CTXT_REFERENCEROOT = 0x0450 :: LONG showPackageContextMenu :: POINT -> SiteServices -> IO () showPackageContextMenu pos services = Oleipc.showContextMenu 0 guidSHLMainMenu idm_VS_CTXT_REFERENCE (pointToPoints pos) Nothing (uiManager services) where idm_VS_CTXT_REFERENCE = 0x0451 :: LONG -- tool definitions pointToPoints :: POINT -> Oleipc.POINTS pointToPoints (POINT x y) = Oleipc.POINTS (fromIntegral x) (fromIntegral y) guidSHLMainMenu :: CLSID guidSHLMainMenu = mkCLSID "{D309F791-903F-11D0-9EFC-00A0C911004F}" ------------------------------------------------------------------------------- -- Messages ------------------------------------------------------------------------------- showMessage :: String -> SiteServices -> IO () showMessage text services = do title <- stringToWide "Visual Haskell" wideText <- stringToWide text Oleipc.showMessage Oleipc.OLEROLE_COMPONENTHOST clsidHaskellPackage title wideText nullWideString 0 Oleipc.OLEMSGBUTTON_OK Oleipc.OLEMSGDEFBUTTON_FIRST Oleipc.OLEMSGICON_INFO 0 (uiManager services) freeWString wideText freeWString title return () ------------------------------------------------------------------------------- -- AddNewItem & AddExistingItem dialogs ------------------------------------------------------------------------------- addNewItemDlg :: VSITEMID -> CLSID -> IVsProject () -> SiteServices -> IO () addNewItemDlg itemid clsid proj services = do (location, filter) <- readIORef (addItemValues services) let flags = fromIntegral (fromEnum VsShell.VSADDITEM_AddNewItems .|. fromEnum VsShell.VSADDITEM_SuggestTemplateName) (location, filter, _) <- VsShell.addProjectItemDlg itemid (clsidToGUID clsid) proj flags nullWideString nullWideString location filter (addItemDlg services) writeIORef (addItemValues services) (location, filter) addExistingItemDlg :: VSITEMID -> CLSID -> IVsProject () -> SiteServices -> IO () addExistingItemDlg itemid clsid proj services = do (location, filter) <- readIORef (addItemValues services) let flags = fromIntegral (fromEnum VsShell.VSADDITEM_AddExistingItems .|. fromEnum VsShell.VSADDITEM_AllowMultiSelect) (location, filter, _) <- VsShell.addProjectItemDlg itemid (clsidToGUID clsid) proj flags nullWideString nullWideString location filter (addItemDlg services) writeIORef (addItemValues services) (location, filter) ------------------------------------------------------------------------------- -- Current Selection ------------------------------------------------------------------------------- getCurrentSelection :: IVsHierarchy () -> SiteServices -> IO [VSITEMID] getCurrentSelection currHierarchy services = do (hierarchy, itemid, mb_multiItemSelect, mb_selContainer) <- VsShell.getCurrentSelection (selMonitor services) maybe (return 0) release mb_multiItemSelect maybe (return 0) release mb_selContainer r <- getSelection hierarchy itemid mb_multiItemSelect when (hierarchy /= interfaceNULL) (release hierarchy >> return ()) return r where getSelection hierarchy itemid mb_multiItemSelect | itemid == vSITEMID_NIL = return [] -- no selection | itemid == vSITEMID_SELECTION = -- multi selection return [] -- TODO: here we need to retrieve the -- list of selected items | otherwise = return (if currHierarchy == hierarchy then [itemid] else []) ------------------------------------------------------------------------------- -- File operations ------------------------------------------------------------------------------- openFile :: FilePath -> IVsUIHierarchy () -> VSITEMID -> SiteServices -> IO (IVsWindowFrame ()) openFile fpath hierarchy itemid services = do wFPath <- stringToWide fpath wCaption <- stringToWide (snd (splitFileName fpath)) interfaceDOCDATAEXISTING_UNKNOWN <- unmarshallIUnknown False (plusPtr nullPtr (-1)) frame <- VsShell.openStandardEditor VsShell.OSE_ChooseBestStdEditor wFPath nullGUID wCaption hierarchy itemid interfaceDOCDATAEXISTING_UNKNOWN interfaceNULL (openDoc services) VsProject.show frame freeWString wCaption freeWString wFPath return frame where nullGUID = mkGUID "{00000000-0000-0000-0000-000000000000}" renameDocFile :: FilePath -> FilePath -> IVsUIHierarchy () -> VSITEMID -> SiteServices -> IO () renameDocFile oldFPath newFPath hierarchy itemid services = do wOldFPath <- stringToWide oldFPath wNewFPath <- stringToWide newFPath interfaceHIERARCHY_DONTCHANGE <- unmarshallIUnknown False (plusPtr nullPtr (-1)) try $ VsShell.renameDocument wOldFPath wNewFPath interfaceHIERARCHY_DONTCHANGE vSITEMID_NIL (runningDocs services) (_, _, frame, isopen) <- VsShell.isDocumentOpen hierarchy itemid wNewFPath nullGUID VsShell.IDO_ActivateIfOpen (openDoc services) when (isopen == 1) $ do var <- allocMemory (fromIntegral sizeofVARIANT) inString (snd (splitFileName newFPath)) (castPtr var) setProperty VSFPROPID_OwnerCaption var frame freeMemory var freeWString wNewFPath freeWString wOldFPath where nullGUID = mkGUID "{00000000-0000-0000-0000-000000000000}"