{-# OPTIONS -cpp -#include windows.h -#include commctrl.h #-} -- ---------------------------------------------------------------------------- -- | -- Module : ProjectFactory -- Author : Krasimir Angelov -- Copyright : (c) Krasimir Angelov, All Rights Reserved -- -- ---------------------------------------------------------------------------- module ProjectFactory ( newHaskellProjectFactory ) where import Wtypes import VsTypes import SiteServices import FilePath import Project(clsidHaskellProject, newHaskellProject) import ProjectState import ProjectContent(getItemBrowserWSName) import TemplateGenerator import ServProv import VsProject( IVsProjectFactory(..), iidIVsProjectFactory, iidIVsHierarchy, IVsHierarchy(..) ) import VsProjectProxy( mkIVsProjectFactory_vtbl ) import VsClassView ( IVsLibraryMgr, iidIVsLibraryMgr , IVsLibrary, iidIVsLibrary , 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 DocObjProxy -- std libraries import Control.Exception(handle) import Control.Monad(unless) import Data.Word import Data.Bits((.&.)) import Data.Array import Data.IORef import System.IO.Unsafe(unsafePerformIO) -- Cabal import Distribution.PackageDescription -- COM import Com import ComServ import WideString import ComException(e_FAIL, e_UNEXPECTED, e_NOTIMPL) import Automation(IDispatch(..), iidIDispatch) #include "../../vs_haskell_ui/resource.h" data ProjectFactoryItems = ProjectFactoryItems {-# UNPACK #-} !ULONG !VSTREELISTITEMCHANGE (Array ULONG ProjectState) data ProjectFactoryState = ProjectFactoryState { factImgLists :: (HIMAGELIST, HIMAGELIST) , factServices :: {-# UNPACK #-} !SiteServices , factName :: {-# UNPACK #-} !WideString , factItems :: {-# UNPACK #-} !(IORef ProjectFactoryItems) , factSelf :: IVsProjectFactory () } newHaskellProjectFactory :: HINSTANCE -> SiteServices -> IO (IVsProjectFactory ()) newHaskellProjectFactory uiInst services = mdo name <- stringToWide "Visual Haskell" pImageList <- loadImageList uiInst IDB_PROJECT_ICONS 16 0 0x00FF00 bImageList <- loadImageList uiInst IDB_BABEL_ICONS 16 0 0x00FF00 itemsRef <- newIORef (ProjectFactoryItems 0 (VSTREELISTITEMCHANGE (-1) TCT_NOCHANGE) (listArray (0,-1) [])) refWString <- newIORef nullWideString let st = ProjectFactoryState { factImgLists = (pImageList,bImageList) , factServices = services , factName = name , factSelf = iProjectFact , factItems = itemsRef } iProjectFact <- createComInstance "" st (releaseProjectFactory st) ifaces_HaskellProjectFactory iidIVsProjectFactory return iProjectFact releaseProjectFactory :: ProjectFactoryState -> IO () releaseProjectFactory st = do freeWString (factName st) canCreateProject :: WideString -> DWORD -> ProjectFactoryState -> IO BOOL canCreateProject pszFilename grfCreateFlags st = do return 1 createProject :: WideString -> WideString -> WideString -> DWORD -> IID (IUnknown i0) -> ProjectFactoryState -> IO (IUnknown i0, BOOL) createProject pszFilename pszLocation pszName grfCreateFlags iidProject st | grfCreateFlags .&. cPF_OPENFILE /= 0 = do filename <- wideToStr pszFilename let (location,fname,ext) = splitFilePath filename name = fname `joinFileExt` ext handle (\ex -> do showMessage (show ex) (factServices st) return (interfaceNULL,1)) $ do pkgDescr <- readPackageDescription filename iProj <- newHaskellProject (factImgLists st) (factServices st) (removeProject st) location name pkgDescr iidProject addProject iProj st return (iProj,0) | grfCreateFlags .&. cPF_CLONEFILE /= 0 = do filename <- wideToStr pszFilename location <- wideToStr pszLocation name <- wideToStr pszName handle (\ex -> do showMessage (show ex) (factServices st) return (interfaceNULL,1)) $ do pkgDescr <- generateProjectTemplate filename location name iProj <- newHaskellProject (factImgLists st) (factServices st) (removeProject st) location name pkgDescr iidProject addProject iProj st return (iProj,0) | otherwise = coFailWithHR e_FAIL "Unsupported operation" where addProject iProject st = do project <- ComServ.getObjState (ifaceToAddr iProject) (ProjectFactoryItems counter (VSTREELISTITEMCHANGE _ change) arr) <- readIORef (factItems st) let projects = elems arr projects' = project : projects writeIORef (factItems st) (ProjectFactoryItems (counter+1) (case change of TCT_NOCHANGE -> VSTREELISTITEMCHANGE (-1) TCT_ITEMADDED _ -> VSTREELISTITEMCHANGE (-1) TCT_TOOMANYCHANGES) (listArray (0,fromIntegral (length projects')-1) projects')) removeProject st iProject = do (ProjectFactoryItems counter (VSTREELISTITEMCHANGE _ change) arr) <- readIORef (factItems st) case removeItem 0 (elems arr) of (i,list') | i >= 0 -> writeIORef (factItems st) (ProjectFactoryItems (counter+1) (case change of TCT_NOCHANGE -> VSTREELISTITEMCHANGE i TCT_ITEMDELETED _ -> VSTREELISTITEMCHANGE (-1) TCT_TOOMANYCHANGES) (case list' of [] -> listArray (1,0) [] _ -> listArray (0,fromIntegral (length list')-1) list')) _ -> return () where removeItem index [] = (-1,[]) removeItem index (p:ps) | prjSelf p == iProject = (index,ps) | otherwise = index' `seq` ps' `seq` (index',ps') where ps' = p:ps'' (index',ps'') = removeItem (index+1) ps setSite :: IServiceProvider a1 -> ProjectFactoryState -> IO () setSite servProv st = do return () close :: ProjectFactoryState -> IO () close st = do destroyImageList (fst (factImgLists st)) destroyImageList (snd (factImgLists st)) freeWString (factName st) return () getCount :: ProjectFactoryState -> IO ULONG getCount st = return 1 getLibraryAt :: ULONG -> ProjectFactoryState -> IO (IVsLibrary ()) getLibraryAt nLibIndex st | nLibIndex /= 0 = coFailWithHR e_UNEXPECTED "Invalid index" | otherwise = queryInterface iidIVsLibrary (factSelf st) getNameAt :: ULONG -> ProjectFactoryState -> IO WideString getNameAt nLibIndex st | nLibIndex /= 0 = coFailWithHR e_UNEXPECTED "Invalid index" | otherwise = return (factName st) toggleCheckAt :: ULONG -> ProjectFactoryState -> IO () toggleCheckAt nLibIndex st = coFailWithHR e_NOTIMPL "toggleCheckAt isn't implemented" getCheckAt :: ULONG -> ProjectFactoryState -> IO LIB_CHECKSTATE getCheckAt nLibIndex st = coFailWithHR e_NOTIMPL "getCheckAt isn't implemented" setLibraryGroupEnabled :: LIB_PERSISTTYPE -> BOOL -> ProjectFactoryState -> IO () setLibraryGroupEnabled lpt fEnable st = coFailWithHR e_NOTIMPL "setLibraryGroupEnabled isn't implemented" getSupportedCategoryFields :: LIB_CATEGORY -> ProjectFactoryState -> IO Word32 getSupportedCategoryFields LC_MEMBERTYPE st = return (fromIntegral (fromEnum (LIBCAT_MEMBERTYPEList__ [LCMT_FUNCTION, LCMT_VARIABLE]))) getSupportedCategoryFields LC_MEMBERACCESS st = return (fromIntegral (fromEnum (LIBCAT_MEMBERACCESSList__ [LCMA_PUBLIC,LCMA_PACKAGE]))) getSupportedCategoryFields LC_CLASSTYPE st = return (fromIntegral (fromEnum (LIBCAT_CLASSTYPEList__ [LCCT_CLASS]))) getSupportedCategoryFields LC_CLASSACCESS st = return (fromIntegral (fromEnum (LIBCAT_CLASSACCESSList__ [LCCA_PUBLIC]))) getSupportedCategoryFields LC_ACTIVEPROJECT st = return (fromIntegral (fromEnum (LIBCAT_ACTIVEPROJECTList__ [LCAP_SHOWALWAYS]))) getSupportedCategoryFields LC_LISTTYPE st = return (fromIntegral (fromEnum (LIB_LISTTYPEList__ [LLT_PACKAGE, LLT_CLASSES, LLT_MEMBERS]))) getSupportedCategoryFields LC_VISIBILITY st = return (fromIntegral (fromEnum (LIBCAT_VISIBILITYList__ [LCV_VISIBLE]))) getSupportedCategoryFields LC_MODIFIER st = return (fromIntegral (fromEnum (LIBCAT_MODIFIERTYPEList__ [LCMDT_STATIC]))) getSupportedCategoryFields _ st = coFailWithHR e_FAIL "Invalid LIB_CATEGORY" getList :: LIB_LISTTYPE -> LIB_LISTFLAGS -> Maybe VSOBSEARCHCRITERIA -> ProjectFactoryState -> IO (IVsObjectList ()) getList listType flags criteria st | (fromEnum flags .&. fromEnum LLF_RESOURCEVIEW) == 0 = queryInterface iidIVsObjectList (factSelf st) | otherwise = coFailWithHR e_UNEXPECTED "Unsupported list type" getLibList :: LIB_PERSISTTYPE -> ProjectFactoryState -> IO (IVsLiteTreeList ()) getLibList persistType st = queryInterface iidIVsLiteTreeList (factSelf st) getLibFlags :: ProjectFactoryState -> IO LIB_FLAGS getLibFlags st = return (LIB_FLAGSList__ [LF_PROJECT,LF_EXPANDABLE]) updateCounter0 :: ProjectFactoryState -> IO ULONG updateCounter0 st = return 0 getGuid :: ProjectFactoryState -> IO GUID getGuid st = return (clsidToGUID clsidHaskellProject) getSeparatorString :: WideString -> ProjectFactoryState -> IO () getSeparatorString str st = coFailWithHR e_NOTIMPL "getSeparatorString isn't implemented" loadState :: Com.IUnknown a -> LIB_PERSISTTYPE -> ProjectFactoryState -> IO () loadState pIStream persistType st = coFailWithHR e_NOTIMPL "loadState isn't implemented" saveState :: Com.IUnknown a -> LIB_PERSISTTYPE -> ProjectFactoryState -> IO () saveState pIStream persistType st = coFailWithHR e_NOTIMPL "loadState isn't implemented" getBrowseContainersForHierarchy :: IVsHierarchy a -> [VSBROWSECONTAINER] -> ProjectFactoryState -> IO ([VSBROWSECONTAINER], ULONG) getBrowseContainersForHierarchy pHierarchy rgBrowseContainer st = coFailWithHR e_NOTIMPL "getBrowseContainersForHierarchy isn't implemented" addBrowseContainer :: VSCOMPONENTSELECTORDATA -> DWORD -> ProjectFactoryState -> IO (DWORD, String) addBrowseContainer pcdComponent pgrfOptions st = coFailWithHR e_NOTIMPL "addBrowseContainer isn't implemented" removeBrowseContainer :: DWORD -> WideString -> ProjectFactoryState -> IO () removeBrowseContainer dwReserved pszLibName1 st = coFailWithHR e_NOTIMPL "removeBrowseContainer isn't implemented" getFlags :: ProjectFactoryState -> IO VSTREEFLAGS getFlags st = return (VSTREEFLAGSList__ [TF_NOEXPANSION,TF_NORELOCATE,TF_NOINSERTDELETE,TF_NOREALIGN,TF_NOEFFECTS,TF_NOCOLORS]) getItemCount :: ProjectFactoryState -> IO ULONG getItemCount st = do (ProjectFactoryItems counter change arr) <- readIORef (factItems st) return (fromIntegral (rangeSize (bounds arr))) 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 -> ProjectFactoryState -> IO WideString getText index tto st = do (ProjectFactoryItems counter change arr) <- readIORef (factItems st) if inRange (bounds arr) index then getItemBrowserWSName vSITEMID_ROOT (prjContent (arr ! index)) else coFailWithHR e_FAIL "Index out of range" getTipText _ _ _ = coFailWithHR e_NOTIMPL "getTipText isn't implemented" getExpandable :: ULONG -> ProjectFactoryState -> IO BOOL getExpandable index st = do (ProjectFactoryItems counter change arr) <- readIORef (factItems st) return (if rangeSize (bounds arr) > 0 then 1 else 0) getDisplayData :: ULONG -> ProjectFactoryState -> IO VSTREEDISPLAYDATA getDisplayData index st = return $! (VSTREEDISPLAYDATA { mask = VSTREEDISPLAYMASKList__ [TDM_IMAGE,TDM_SELECTEDIMAGE] , state = VSTREEDISPLAYSTATEList__ [] , stateMask = VSTREEDISPLAYSTATEList__ [] , image = 0 , selectedImage = 0 , hImageList = fst (factImgLists st) , forceSelectStart = 0 , forceSelectLength = 0 }) updateCounter :: ProjectFactoryState -> IO (ULONG, VSTREEITEMCHANGESMASK) updateCounter st = do (ProjectFactoryItems counter change arr) <- readIORef (factItems st) writeIORef (factItems st) (ProjectFactoryItems counter (VSTREELISTITEMCHANGE (-1) TCT_NOCHANGE) arr) return (counter,grfChange change) getListChanges :: ULONG -> ProjectFactoryState -> IO [VSTREELISTITEMCHANGE] getListChanges count st | count /= 1 = coFailWithHR e_UNEXPECTED "Invalid count" | otherwise = do (ProjectFactoryItems counter change arr) <- readIORef (factItems st) writeIORef (factItems st) (ProjectFactoryItems counter (VSTREELISTITEMCHANGE (-1) TCT_NOCHANGE) arr) 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 -> ProjectFactoryState -> IO (IVsObjectList ()) getList0 index LLT_NAMESPACES listFlags _ st = do (ProjectFactoryItems counter change arr) <- readIORef (factItems st) if inRange (bounds arr) index then queryInterface iidIVsObjectList (prjSelf (arr ! index)) else coFailWithHR e_FAIL "Index out of range" getList0 _ _ _ _ _ = do coFailWithHR e_UNEXPECTED "Unsupported list type" getCategoryField :: ULONG -> LIB_CATEGORY -> ProjectFactoryState -> IO DWORD getCategoryField index LC_LISTTYPE st = return (fromIntegral (fromEnum LLT_NAMESPACES)) 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 -> ProjectFactoryState -> IO (IDispatch ()) getBrowseObject index st = do (ProjectFactoryItems _ _ arr) <- readIORef (factItems st) if inRange (bounds arr) index then queryInterface iidIDispatch (prjSelf (arr ! index)) else coFailWithHR e_FAIL "Index out of range" 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 -> ProjectFactoryState -> IO (IVsHierarchy (), VSITEMID, ULONG) countSourceItems index st = do (ProjectFactoryItems _ _ arr) <- readIORef (factItems st) if inRange (bounds arr) index then do iHier <- queryInterface iidIVsHierarchy (prjSelf (arr ! index)) return (iHier, vSITEMID_NIL, 0) else coFailWithHR e_FAIL "Index out of range" getMultipleSourceItems _ _ _ _ = coFailWithHR e_NOTIMPL "getMultipleSourceItems isn't implemented" canGoToSource :: ULONG -> VSOBJGOTOSRCTYPE -> ProjectFactoryState -> IO BOOL canGoToSource index srcType st = return 0 goToSource :: ULONG -> VSOBJGOTOSRCTYPE -> ProjectFactoryState -> IO () goToSource index srcType st = return () getContextMenu :: ULONG -> ProjectFactoryState -> IO (CLSID, LONG, IOleCommandTarget ()) getContextMenu index st = do (ProjectFactoryItems _ _ arr) <- readIORef (factItems st) if inRange (bounds arr) index then do iCmdTarget <- queryInterface iidIOleCommandTarget (prjSelf (arr ! index)) return (guidSHLMainMenu, idm_VS_CTXT_PROJNODE, iCmdTarget) else coFailWithHR e_FAIL "Index out of range" where idm_VS_CTXT_PROJNODE = 0x402 :: 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" iVsProjectFactory_vtbl :: ComServ.ComVTable (IVsProjectFactory ()) ProjectFactoryState iVsProjectFactory_vtbl = unsafePerformIO (mkIVsProjectFactory_vtbl canCreateProject createProject setSite close) iVsLibraryMgr_vtbl :: ComServ.ComVTable (IVsLibraryMgr ()) ProjectFactoryState iVsLibraryMgr_vtbl = unsafePerformIO (mkIVsLibraryMgr_vtbl getCount getLibraryAt getNameAt toggleCheckAt getCheckAt setLibraryGroupEnabled) iVsLibrary_vtbl :: ComServ.ComVTable (IVsLibrary ()) ProjectFactoryState iVsLibrary_vtbl = unsafePerformIO (mkIVsLibrary_vtbl getSupportedCategoryFields getList getLibList getLibFlags updateCounter0 getGuid getSeparatorString loadState saveState getBrowseContainersForHierarchy addBrowseContainer removeBrowseContainer) iVsObjectList_vtbl :: ComServ.ComVTable (IVsObjectList ()) ProjectFactoryState 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) ifaces_HaskellProjectFactory :: [ComInterface ProjectFactoryState] ifaces_HaskellProjectFactory = [ ComServ.mkIface iidIVsProjectFactory iVsProjectFactory_vtbl , ComServ.mkIface iidIVsLibraryMgr iVsLibraryMgr_vtbl , ComServ.mkIface iidIVsLibrary iVsLibrary_vtbl , ComServ.mkIface iidIVsLiteTreeList iVsObjectList_vtbl , ComServ.mkIface iidIVsObjectList iVsObjectList_vtbl ] foreign import stdcall unsafe "ImageList_LoadBitmap" loadImageList :: HINSTANCE -> Int -> Int -> Int -> Word32 -> IO HIMAGELIST foreign import stdcall unsafe "ImageList_Destroy" destroyImageList :: HIMAGELIST -> IO BOOL