-- ---------------------------------------------------------------------------- -- | -- Module : ProjectContent -- Author : Krasimir Angelov -- Copyright : (c) Krasimir Angelov, All Rights Reserved -- -- ---------------------------------------------------------------------------- module ProjectContent ( ProjectContent, ProjectMetaInfo(..), ItemKind(..), FileKind(..) , newProjectMetaInfo , newProjectContent , clearProjectContent , getProjectContentMetaInfo, setProjectContentMetaInfo , getProjectContentIsDirty , getProjectContentHasNonProjItems, setProjectContentHasNonProjItems , getProjectContentBuildInfo, setProjectContentBuildInfo , getProjectContentMainIs, setProjectContentMainIs , getProjectContentHsSourceDirs , getProjectContentDependencies , addFileItem, addLicenseFileItem, addFolderItem , addPackageDep , removeItem , includeItemInProject , excludeItemFromProject , updateModulesCounter , getItemKind, setItemFileKind , getItemName, setItemName , getItemDisplayName, getItemBrowserWSName , getItemFilePath , getItemGHCModule, getItemAllGHCModules , getItemVersion, setItemVersion , getItemVersionRange, setItemVersionRange , isFileInProject , getNextItemID, getPrevItemID, getParentItemID, getChildItemID , setItemTyThings , getItemTyThings , getItemUpdateCounter , extractPackageDescription , addHierarchyEventListener , removeHierarchyEventListener , notifyPropertyChanged ) where import VsProject( IVsHierarchyEvents(..) , onItemAdded , onItemsAppended , onItemDeleted , onPropertyChanged , onInvalidateItems ) import VsClassView ( VSTREELISTITEMCHANGE(..) , VSTREEITEMCHANGESMASK(..) ) import Wtypes(ULONG) import VsTypes(VSITEMID, vSITEMID_ROOT, vSITEMID_NIL, VSHPROPID(..), VSCOOKIE) import Control.Monad(when, unless) import Data.Array import Data.IORef import Data.HashTable import Data.Char ( toUpper ) import qualified Data.List as List(lookup) import System.Directory import Text.PrettyPrint import Prelude hiding (lookup) import Event import FilePath import VSConfig(setupScriptName) import WideString import Foreign hiding (new) import Foreign.C import Distribution.Package import Distribution.Version import Distribution.ParseUtils (showDependency) import Distribution.Simple.Utils import Distribution.License import Distribution.PackageDescription import Distribution.Setup(CompilerFlavor(..)) import Control.Monad(filterM) import Control.Exception(handle) import Debug.Trace import VsGHC as GHC import Module import NameSet data ProjectMetaInfo = ProjectMetaInfo { miLicense :: License , miCopyright :: String , miMaintainer :: String , miAuthor :: String , miStability :: String , miTestedWith :: [(CompilerFlavor,VersionRange)] , miHomepage :: String , miPkgURL :: String , miSynopsis :: String , miDescription :: String , miCategory :: String } data ProjectContent = ProjectContent { nextItemID :: !(IORef VSITEMID) , dirtyFlag :: !(IORef Bool) , nonProjItems :: !(IORef Bool) , rootItemRef :: !ProjectItemRef , nullItemRef :: !ProjectItemRef , filesMap :: HashTable VSITEMID ProjectItemRef , hierEvent :: Event (IVsHierarchyEvents ()) , projMetaInfo :: !(IORef ProjectMetaInfo) , projBuildInfo:: !(IORef BuildInfo) , projMainIs :: !(IORef FilePath) , projLICENSE :: !(IORef VSITEMID) , projModules :: !(IORef ProjectModules) } data ProjectItem = RootItem { itemId :: !VSITEMID , itemName :: !String , itemFKind :: !FileKind , itemChild :: !ProjectItemRef , itemVersion:: !Version , itemWSName :: !WideString } | ReferencesItem { itemId :: !VSITEMID , itemName :: !String , itemNext :: !ProjectItemRef , itemPrev :: !ProjectItemRef , itemParent :: !ProjectItemRef , itemChild :: !ProjectItemRef } | FolderItem { itemId :: !VSITEMID , itemName :: !String , itemFKind :: !FileKind , itemNext :: !ProjectItemRef , itemPrev :: !ProjectItemRef , itemParent :: !ProjectItemRef , itemChild :: !ProjectItemRef } | FileItem { itemId :: !VSITEMID , itemName :: !String , itemFKind :: !FileKind , itemNext :: !ProjectItemRef , itemPrev :: !ProjectItemRef , itemParent :: !ProjectItemRef , itemModule :: !ProjectModule } | PackageItem { itemId :: !VSITEMID , itemName :: !String , itemNext :: !ProjectItemRef , itemPrev :: !ProjectItemRef , itemParent :: !ProjectItemRef , itemVerRng :: !VersionRange } | NullItem type ProjectItemRef = IORef ProjectItem data ItemKind = Root | References | File FileKind | Folder FileKind | Package | Null deriving Eq data FileKind = ExposedModule | HiddenModule | CSource | HSource | TextFile | SetupScript | LicenseText | HsSourceFolder | PlainFolder | NPFile -- not in project file deriving Eq data ProjectModules = ProjectModules !ULONG !VSTREELISTITEMCHANGE !(Array Int (VSITEMID,ModuleName)) data ProjectModule = ProjectModule { pmodModule :: !ModuleName , pmodTyThings :: !(Array Int TyThing ) , pmodInstances :: !(Array Int Instance) , pmodIsExported :: !(Name -> Bool) , pmodCounter1 :: !ULONG , pmodCounter2 :: !ULONG , pmodWSName :: !WideString } | NoProjectModule mkEmptyProjectModule :: ModuleName -> IO ProjectModule mkEmptyProjectModule mdl = do ws <- stringToWide (moduleNameString mdl) return (ProjectModule mdl (listArray (0,-1) []) (listArray (0,-1) []) (const False) 0 0 ws) newProjectMetaInfo :: PackageDescription -> ProjectMetaInfo newProjectMetaInfo pkgDescr = ProjectMetaInfo { miLicense = license pkgDescr , miCopyright = copyright pkgDescr , miMaintainer = maintainer pkgDescr , miAuthor = author pkgDescr , miStability = stability pkgDescr , miTestedWith = testedWith pkgDescr , miHomepage = homepage pkgDescr , miPkgURL = pkgUrl pkgDescr , miSynopsis = synopsis pkgDescr , miDescription = description pkgDescr , miCategory = category pkgDescr } --------------------------------------------------------------------- -- Utils --------------------------------------------------------------------- -- | The function adds a new project item of the given kind to the tree. If the specified -- kind for files doesn't match to their name/suffix then the kind will be updated. insertProjectItem :: ItemKind -> Bool -> VSITEMID -> String -> ProjectContent -> IO VSITEMID insertProjectItem kind isNew parentid name content = do mb_item <- lookup (filesMap content) parentid case mb_item of Just parentRef -> do parent <- readIORef parentRef prevRef <- findItem name (nullItemRef content) (itemChild parent) prev <- readIORef prevRef let addNew = case prev of NullItem -> True prev -> itemName prev /= name || isNew if addNew then do id <- readIORef (nextItemID content) let nextRef = case prev of NullItem -> itemChild parent _ -> itemNext prev item <- case kind of References -> return (ReferencesItem id name nextRef prevRef parentRef (nullItemRef content)) Folder kind -> return (FolderItem id name kind nextRef prevRef parentRef (nullItemRef content)) File kind -> do let kind' = updateFKind parent name kind pmod <- addModule id parent kind' name content return (FileItem id name kind' nextRef prevRef parentRef pmod) Package -> return (PackageItem id name nextRef prevRef parentRef AnyVersion) itemRef <- newIORef item case prev of NullItem -> writeIORef parentRef parent{itemChild=itemRef} _ -> writeIORef prevRef prev{itemNext=itemRef} next <- readIORef nextRef case next of NullItem -> return () _ -> writeIORef nextRef next{itemPrev=itemRef} writeIORef (nextItemID content) (id+1) writeIORef (dirtyFlag content) True insert (filesMap content) (itemId item) itemRef notifyItemAdded content (itemId parent) (case prev of NullItem -> vSITEMID_NIL _ -> itemId prev) (itemId item) return id else return (itemId prev) Nothing -> return vSITEMID_NIL where findItem name prevRef itemRef = do item <- readIORef itemRef case kind of References-> return prevRef Folder _ -> case item of FolderItem{} | name < itemName item -> return prevRef FileItem{} -> return prevRef NullItem -> return prevRef item -> findItem name itemRef (itemNext item) File _ -> case item of FileItem{} | name < itemName item -> return prevRef NullItem -> return prevRef item -> findItem name itemRef (itemNext item) Package -> case item of PackageItem{} | name < itemName item -> return prevRef NullItem -> return prevRef item -> findItem name itemRef (itemNext item) insertFilePathFoldersItem parentid fpath content | fpath == "." = return parentid | otherwise = do parentid <- insertFilePathFoldersItem parentid subpath content itemid <- insertProjectItem (Folder PlainFolder) False parentid name content notifyPropertyChanged content parentid VSHPROPID_Expandable return itemid where (subpath,name) = splitFileName fpath lookupProjectItem :: VSITEMID -> ProjectContent -> IO ProjectItemRef lookupProjectItem itemid content = do mb_item <- lookup (filesMap content) itemid maybe (return (nullItemRef content)) return mb_item addModule itemid parent kind name content = do mb_mdl <- if kind == ExposedModule || kind == HiddenModule then do mb_modname <- getModuleName parent (capFirstChar (fst (splitFileExt name))) return (fmap mkModuleName mb_modname) else return Nothing case mb_mdl of Just mdl -> do (ProjectModules counter change arr) <- readIORef (projModules content) let items = elems arr writeIORef (projModules content) (ProjectModules (counter+1) (case grfChange change of TCT_NOCHANGE -> VSTREELISTITEMCHANGE (-1) TCT_ITEMADDED _ -> VSTREELISTITEMCHANGE (-1) TCT_TOOMANYCHANGES) (listArray (0,length items) ((itemid,mdl):items))) mkEmptyProjectModule mdl Nothing -> return NoProjectModule removeModule itemid content = do (ProjectModules counter change arr) <- readIORef (projModules content) let (i',items') = remove 0 (elems arr) when (i' /= -1) $ writeIORef (projModules content) (ProjectModules (counter+1) (case grfChange change of TCT_NOCHANGE -> VSTREELISTITEMCHANGE i' TCT_ITEMDELETED _ -> VSTREELISTITEMCHANGE (-1) TCT_TOOMANYCHANGES) (listArray (0,length items'-1) items')) where remove i [] = (-1,[]) remove i (item'@(itemid',_):items) | itemid == itemid' = (i,items) | otherwise = (i',item':items') where (i',items') = remove (i+1) items updateModule itemid mdl content = do (ProjectModules counter change arr) <- readIORef (projModules content) let (i',items') = update 0 (elems arr) writeIORef (projModules content) (ProjectModules (counter+1) (case grfChange change of TCT_NOCHANGE | i' /= -1 -> VSTREELISTITEMCHANGE i' TCT_ITEMPROPSCHANGED | otherwise -> VSTREELISTITEMCHANGE i' TCT_ITEMADDED _ -> VSTREELISTITEMCHANGE (-1) TCT_TOOMANYCHANGES) (listArray (0,length items'-1) items')) where update i [] = (-1,[(itemid,mdl)]) update i (item'@(itemid',_):items) | itemid == itemid' = (i ,(itemid,mdl):items ) | otherwise = (i',item' :items') where (i',items') = update (i+1) items --------------------------------------------------------------------- -- Content management API --------------------------------------------------------------------- newProjectContent :: FilePath -> PackageDescription -> IO ProjectContent newProjectContent location pkgDescr = do event <- newEvent nextItemID <- newIORef 1 dirtyFlag <- newIORef False filesMap <- new (==) fromIntegral npItemsFlag<- newIORef False nullItemRef<- newIORef NullItem ws <- stringToWide (showPackageId (package pkgDescr)) rootItemRef<- newIORef (RootItem vSITEMID_ROOT (pkgName (package pkgDescr)) PlainFolder nullItemRef (pkgVersion (package pkgDescr)) ws) insert filesMap vSITEMID_ROOT rootItemRef refMetaInfo <- newIORef (newProjectMetaInfo pkgDescr) refBuild <- newIORef emptyBuildInfo refMainIs <- newIORef "" refLICENSE <- newIORef vSITEMID_NIL refModules <- newIORef (ProjectModules 0 (VSTREELISTITEMCHANGE (-1) TCT_NOCHANGE) (listArray (0,-1) [])) let content = ProjectContent nextItemID dirtyFlag npItemsFlag rootItemRef nullItemRef filesMap event refMetaInfo refBuild refMainIs refLICENSE refModules addPackageDescriptionItems pkgDescr content writeIORef dirtyFlag False return content where addPackageDescriptionItems pkgDescr content = do addReferencesItems (buildDepends pkgDescr) case library pkgDescr of Just (Library {libBuildInfo=binfo, exposedModules=exp_mods}) -> do addBuildInfoItems binfo exp_mods Nothing -> case executables pkgDescr of (Executable _ mainIs binfo:_) -> do addBuildInfoItems binfo [] writeIORef (projMainIs content) mainIs _ -> return () unless (null (licenseFile pkgDescr)) $ do itemid <- mkFileItem vSITEMID_ROOT LicenseText content (licenseFile pkgDescr) writeIORef (projLICENSE content) itemid exists <- doesFileExist (location `joinFileName` setupScriptName) when exists $ do mkFileItem vSITEMID_ROOT SetupScript content setupScriptName return () mapM_ (mkFileItem vSITEMID_ROOT TextFile content) (extraSrcFiles pkgDescr) where addReferencesItems deps = do depId <- insertProjectItem References True vSITEMID_ROOT "References" content mapM_ (\n -> addPackageDep depId n content) deps notifyPropertyChanged content depId VSHPROPID_Expandable addBuildInfoItems binfo exp_mods = do writeIORef (projBuildInfo content) (binfo{ otherModules=[] , cSources=[] , hsSourceDirs=[] }) dirs <- mapM (\src_dir -> do itemid <- insertFilePathFoldersItem vSITEMID_ROOT src_dir content setItemFileKind itemid HsSourceFolder content return (src_dir,itemid) ) (hsSourceDirs binfo) mapM_ (mkModuleItem dirs ExposedModule content) (exp_mods) mapM_ (mkModuleItem dirs HiddenModule content) (otherModules binfo) mapM_ (mkFileItem vSITEMID_ROOT CSource content) (cSources binfo) mkModuleItem [] fkind content modName = error ("Module "++modName++" is missing") mkModuleItem ((src_dir,parentid):dirs) fkind content modName = do mb_path <- findModulePath (location `joinFileName` src_dir) modName case mb_path of Just path -> mkFileItem parentid fkind content path Nothing -> mkModuleItem dirs fkind content modName mkFileItem parentid fkind content fpath = do parentid <- insertFilePathFoldersItem parentid dir content itemid <- insertProjectItem (File fkind) True parentid name content notifyPropertyChanged content parentid VSHPROPID_Expandable return itemid where (dir,name) = splitFileName fpath knownSuffixes = [ "chs", "hsc", "y", "ly", "x", "cpphs", "gc", "hs", "lhs" ] findModulePath :: FilePath -- ^project location -> String -- ^Module Name -> IO (Maybe FilePath) findModulePath location modName = withCString location $ \c_location -> withCString modName $ \c_modName -> withMany withCString knownSuffixes $ \extPtrs -> withArray0 nullPtr extPtrs $ \c_exts -> do c_modPath <- c_findProjectModule c_location c_modName c_exts if c_modPath == nullPtr then return Nothing else do modPath <- peekCString c_modPath free c_modPath return (Just modPath) foreign import ccall "findModule" c_findProjectModule :: CString -> CString -> Ptr CString -> IO CString clearProjectContent :: ProjectContent -> IO () clearProjectContent content = clearEvent (hierEvent content) getProjectContentMetaInfo :: ProjectContent -> IO ProjectMetaInfo getProjectContentMetaInfo content = readIORef (projMetaInfo content) setProjectContentMetaInfo :: ProjectContent -> ProjectMetaInfo -> IO () setProjectContentMetaInfo content metaInfo = do writeIORef (projMetaInfo content) metaInfo writeIORef (dirtyFlag content) True getProjectContentIsDirty :: ProjectContent -> IO Bool getProjectContentIsDirty content = readIORef (dirtyFlag content) getProjectContentHasNonProjItems :: ProjectContent -> IO Bool getProjectContentHasNonProjItems content = readIORef (nonProjItems content) setProjectContentHasNonProjItems :: FilePath -> Bool -> ProjectContent -> IO () setProjectContentHasNonProjItems location flag content = do writeIORef (nonProjItems content) flag dirty <- readIORef (dirtyFlag content) if flag then addNonProjectItems vSITEMID_ROOT location else removeNonProjectItems (rootItemRef content) writeIORef (dirtyFlag content) dirty where addNonProjectItems :: VSITEMID -> FilePath -> IO () addNonProjectItems parentid dirPath = do getDirectoryContents dirPath >>= mapM_ (processFile dirPath) notifyPropertyChanged content parentid VSHPROPID_Expandable where processFile dirPath fileName | fileName == "." || fileName == ".." = return () | otherwise = do isDir <- doesDirectoryExist filePath let kind | isDir = Folder NPFile | otherwise = File NPFile itemid <- insertProjectItem kind False parentid fileName content when isDir (addNonProjectItems itemid filePath) where filePath = dirPath `joinFileName` fileName removeNonProjectItems itemRef = do item <- readIORef itemRef case item of RootItem{} -> do removeNonProjectItems (itemChild item) ReferencesItem{} -> do removeNonProjectItems (itemNext item) FolderItem{} -> do if itemFKind item == NPFile then removeItem (itemId item) content else removeNonProjectItems (itemChild item) removeNonProjectItems (itemNext item) FileItem{} -> do when (itemFKind item == NPFile) $ do removeItem (itemId item) content removeNonProjectItems (itemNext item) NullItem -> do return () getProjectContentBuildInfo :: ProjectContent -> IO BuildInfo getProjectContentBuildInfo content = readIORef (projBuildInfo content) setProjectContentBuildInfo :: ProjectContent -> BuildInfo -> IO () setProjectContentBuildInfo content binfo = do writeIORef (projBuildInfo content) binfo writeIORef (dirtyFlag content) True getProjectContentMainIs :: ProjectContent -> IO FilePath getProjectContentMainIs content = readIORef (projMainIs content) setProjectContentMainIs :: ProjectContent -> FilePath -> IO () setProjectContentMainIs content binfo = do writeIORef (projMainIs content) binfo writeIORef (dirtyFlag content) True getProjectContentHsSourceDirs :: FilePath -> ProjectContent -> IO [FilePath] getProjectContentHsSourceDirs location content = readIORef (rootItemRef content) >>= loop [] where loop path NullItem = return [] loop path item@(RootItem{}) = do dirs <- readIORef (itemChild item) >>= loop [] case itemFKind item of HsSourceFolder -> return (location : dirs) _ -> return dirs loop path item@(FolderItem{}) = do dirs1 <- readIORef (itemNext item) >>= loop path dirs2 <- readIORef (itemChild item) >>= loop (itemName item:path) let dirs = dirs1++dirs2 case itemFKind item of HsSourceFolder -> return (mkFilePath path (itemName item) : dirs) _ -> return dirs loop path item = readIORef (itemNext item) >>= loop path mkFilePath [] fpath = location `joinFileName` fpath mkFilePath (x:xs) fpath = mkFilePath xs (x++'/':fpath) getProjectContentDependencies :: ProjectContent -> IO [Dependency] getProjectContentDependencies content = do rootItem <- readIORef (rootItemRef content) depItem <- readIORef (itemChild rootItem) depItem <- readIORef (itemChild depItem) loop depItem [] where loop NullItem deps = return deps loop item deps = do nextItem <- readIORef (itemNext item) loop nextItem ((Dependency (itemName item) (itemVerRng item)) : deps) addFileItem :: VSITEMID -> String -> ProjectContent -> IO VSITEMID addFileItem parentid title content = do itemid <- insertProjectItem (File HiddenModule) False parentid title content notifyPropertyChanged content parentid VSHPROPID_Expandable return itemid addLicenseFileItem :: VSITEMID -> String -> ProjectContent -> IO VSITEMID addLicenseFileItem parentid name content = do licenseFileId <- readIORef (projLICENSE content) if licenseFileId == vSITEMID_NIL then do licenseFileId <- insertProjectItem (File LicenseText) False parentid name content writeIORef (projLICENSE content) licenseFileId notifyPropertyChanged content parentid VSHPROPID_Expandable return licenseFileId else return licenseFileId addFolderItem :: VSITEMID -> String -> ProjectContent -> IO VSITEMID addFolderItem parentid title content = do itemid <- insertProjectItem (Folder PlainFolder) True parentid title content notifyPropertyChanged content parentid VSHPROPID_Expandable return itemid addPackageDep :: VSITEMID -> Dependency -> ProjectContent -> IO VSITEMID addPackageDep parentid (Dependency name verRange) content = do id <- insertProjectItem Package True parentid name content ref <- lookupProjectItem id content modifyIORef ref (\item->item{itemVerRng=verRange}) notifyPropertyChanged content id VSHPROPID_Caption notifyPropertyChanged content parentid VSHPROPID_Expandable return id removeItem :: VSITEMID -> ProjectContent -> IO () removeItem itemid content = do notifyItemDeleted content itemid itemRef <- lookupProjectItem itemid content item <- readIORef itemRef case item of NullItem -> return () RootItem{} -> do recursiveCleanHash (filesMap content) item writeIORef (dirtyFlag content) True item -> do recursiveCleanHash (filesMap content) item -- clear the projLICENSE field if this is the LICENSE item case item of FileItem{itemFKind=kind} | kind == LicenseText -> writeIORef (projLICENSE content) vSITEMID_NIL | kind == ExposedModule || kind == HiddenModule -> removeModule itemid content _ -> return () parent <- readIORef (itemParent item) next <- readIORef (itemNext item) prev <- readIORef (itemPrev item) case next of NullItem -> return () next -> writeIORef (itemNext item) next{itemPrev=itemPrev item} case prev of NullItem -> writeIORef (itemParent item) parent{itemChild=itemNext item} prev -> writeIORef (itemPrev item) prev{itemNext=itemNext item} notifyPropertyChanged content (itemId parent) VSHPROPID_Expandable writeIORef (dirtyFlag content) True where recursiveCleanHash :: HashTable VSITEMID ProjectItemRef -> ProjectItem -> IO () recursiveCleanHash ht (RootItem {itemId=id, itemChild=child}) = do delete ht id readIORef child >>= iterate ht recursiveCleanHash ht (ReferencesItem {itemId=id, itemChild=child}) = do delete ht id readIORef child >>= iterate ht recursiveCleanHash ht (FolderItem {itemId=id, itemChild=child}) = do delete ht id readIORef child >>= iterate ht recursiveCleanHash ht (FileItem {itemId=id}) = do delete ht id recursiveCleanHash ht (PackageItem {itemId=id}) = do delete ht id recursiveCleanHash ht (NullItem) = return () iterate :: HashTable VSITEMID ProjectItemRef -> ProjectItem -> IO () iterate ht i@(ReferencesItem {itemId=id, itemNext=next}) = do delete ht id recursiveCleanHash ht i readIORef next >>= iterate ht iterate ht i@(FolderItem {itemId=id, itemNext=next}) = do delete ht id recursiveCleanHash ht i readIORef next >>= iterate ht iterate ht (FileItem {itemId=id, itemNext=next}) = do delete ht id readIORef next >>= iterate ht iterate ht (PackageItem {itemId=id, itemNext=next}) = do delete ht id readIORef next >>= iterate ht iterate ht _ = return () includeItemInProject :: VSITEMID -> ProjectContent -> IO () includeItemInProject itemid content = do itemRef <- lookupProjectItem itemid content includeParents itemRef writeIORef (dirtyFlag content) True where includeParents itemRef = do item <- readIORef itemRef case item of FolderItem{itemFKind=NPFile} -> do writeIORef itemRef item{itemFKind=PlainFolder} parentid <- getParentItemID (itemId item) content notifyInvalidateItems content parentid includeParents (itemParent item) FileItem{itemFKind=NPFile} -> do parent <- readIORef (itemParent item) let kind' = updateFKind parent (itemName item) HiddenModule pmod <- addModule (itemId item) parent kind' (itemName item) content writeIORef itemRef item{itemFKind=kind', itemModule=pmod} notifyPropertyChanged content (itemId item) VSHPROPID_IconIndex includeParents (itemParent item) _ -> return () excludeItemFromProject :: VSITEMID -> ProjectContent -> IO () excludeItemFromProject itemid content = do hasNPItems <- readIORef (nonProjItems content) if hasNPItems then do itemRef <- lookupProjectItem itemid content item <- readIORef itemRef case item of FileItem{} -> do removeModule itemid content writeIORef itemRef item{itemFKind=NPFile} FolderItem{} -> writeIORef itemRef item{itemFKind=NPFile} writeIORef (dirtyFlag content) True case item of FolderItem{} -> do excludeAll (itemChild item) parentid <- getParentItemID itemid content notifyInvalidateItems content parentid _ -> notifyPropertyChanged content itemid VSHPROPID_IconIndex else removeItem itemid content where excludeAll itemRef = do item <- readIORef itemRef case item of FolderItem{} -> do writeIORef itemRef item{itemFKind=NPFile} excludeAll (itemChild item) excludeAll (itemNext item) FileItem{} -> do removeModule (itemId item) content writeIORef itemRef item{itemFKind=NPFile} excludeAll (itemNext item) _ -> return () updateModulesCounter :: ProjectContent -> IO (ULONG, VSTREELISTITEMCHANGE) updateModulesCounter content = do (ProjectModules counter change arr) <- readIORef (projModules content) writeIORef (projModules content) (ProjectModules counter (VSTREELISTITEMCHANGE (-1) TCT_NOCHANGE) arr) return (counter,change) getItemKind :: VSITEMID -> ProjectContent -> IO ItemKind getItemKind itemid content = do item <- lookupProjectItem itemid content >>= readIORef return (case item of RootItem{} -> Root ReferencesItem{}->References FolderItem{} -> Folder (itemFKind item) FileItem{} -> File (itemFKind item) PackageItem{} -> Package NullItem -> Null) getItemName :: VSITEMID -> ProjectContent -> IO String getItemName itemid content = do item <- lookupProjectItem itemid content >>= readIORef return (itemName item) setItemName :: VSITEMID -> String -> ProjectContent -> IO () setItemName itemid name content = do itemRef <- lookupProjectItem itemid content item <- readIORef itemRef case item of NullItem -> return () item@(RootItem{}) -> do unless (itemWSName item == nullWideString) (freeWString (itemWSName item)) ws <- stringToWide (showPackageId (PackageIdentifier name (itemVersion item))) let item' = item{itemName=name, itemWSName=ws} writeIORef itemRef item' writeIORef (dirtyFlag content) True case itemFKind item of HsSourceFolder -> updateModuleNames "" itemRef content _ -> return () notifyPropertyChanged content itemid VSHPROPID_Caption item@(FileItem{}) -> do parent <- readIORef (itemParent item) let item' = item{ itemName =name , itemFKind=updateFKind parent name (itemFKind item) } mb_modName <- getModuleName item' "" pmod' <- case mb_modName of Just mdl -> case itemModule item of NoProjectModule -> mkEmptyProjectModule (mkModuleName mdl) pmod -> do unless (pmodWSName pmod == nullWideString) (freeWString (pmodWSName pmod)) ws <- stringToWide mdl return (pmod{pmodModule=mkModuleName mdl, pmodWSName=ws}) Nothing -> return NoProjectModule writeIORef itemRef item'{itemModule=pmod'} case pmod' of NoProjectModule -> removeModule itemid content pmod -> updateModule itemid (pmodModule pmod) content writeIORef (dirtyFlag content) True notifyPropertyChanged content itemid VSHPROPID_Caption notifyPropertyChanged content itemid VSHPROPID_IconIndex item -> do let item' = item{itemName=name} writeIORef itemRef item' writeIORef (dirtyFlag content) True mb_modName <- getModuleName item' "" case mb_modName of Just modName -> updateModuleNames modName itemRef content Nothing -> return () notifyPropertyChanged content itemid VSHPROPID_Caption updateModuleNames modPath itemRef content = do item <- readIORef itemRef let mdl = mkModuleName modPath case item of RootItem{} -> updateChildModuleNames modPath (itemChild item) content FileItem{} -> do case itemModule item of NoProjectModule -> return () pmod -> do updateModule (itemId item) mdl content writeIORef itemRef item{itemModule=pmod{pmodModule=mdl}} FolderItem{} -> do case itemFKind item of HsSourceFolder -> updateChildModuleNames "" (itemChild item) content PlainFolder -> updateChildModuleNames modPath (itemChild item) content _ -> return () _ -> return () where updateChildModuleNames modPath itemRef content = do item <- readIORef itemRef case item of NullItem -> return () _ -> do let (_,modFPath,_) = splitFilePath (itemName item) modName = capFirstChar modFPath modPath' | null modPath = modName | otherwise = modPath++'.':modName updateModuleNames modPath' itemRef content updateChildModuleNames modPath (itemNext item) content updateFKind parent name fkind | fkind == NPFile = NPFile | name == setupScriptName = case parent of RootItem{} -> SetupScript _ -> case fkind of ExposedModule -> ExposedModule _ -> HiddenModule | fext `elem` knownSuffixes = case fkind of ExposedModule -> ExposedModule _ -> HiddenModule | fext == "c" = CSource | fext == "h" = HSource | otherwise = case fkind of LicenseText -> LicenseText _ -> TextFile where (_,fext) = splitFileExt name getItemDisplayName :: VSITEMID -> ProjectContent -> IO String getItemDisplayName itemid content = do item <- lookupProjectItem itemid content >>= readIORef let pkg_id = PackageIdentifier (itemName item) (itemVersion item) dep = Dependency (itemName item) (itemVerRng item) disp_name = case item of RootItem{} -> showPackageId pkg_id PackageItem{} -> render (showDependency dep) item -> itemName item return disp_name getItemBrowserWSName :: VSITEMID -> ProjectContent -> IO WideString getItemBrowserWSName itemid content = do item <- lookupProjectItem itemid content >>= readIORef return (case item of RootItem{itemWSName=ws} -> ws FileItem{itemModule=ProjectModule{pmodWSName=ws}} -> ws _ -> nullWideString) getItemVersion :: VSITEMID -> ProjectContent -> IO Version getItemVersion itemid content = do item <- lookupProjectItem itemid content >>= readIORef return (itemVersion item) setItemVersion :: VSITEMID -> Version -> ProjectContent -> IO () setItemVersion itemid version content = do itemRef <- lookupProjectItem itemid content item <- readIORef itemRef case item of NullItem -> return () RootItem{} -> do unless (itemWSName item == nullWideString) (freeWString (itemWSName item)) ws <- stringToWide (showPackageId (PackageIdentifier (itemName item) version)) writeIORef itemRef item{itemVersion=version, itemWSName=ws} writeIORef (dirtyFlag content) True notifyPropertyChanged content itemid VSHPROPID_Caption getItemVersionRange :: VSITEMID -> ProjectContent -> IO VersionRange getItemVersionRange itemid content = do item <- lookupProjectItem itemid content >>= readIORef return (itemVerRng item) setItemVersionRange :: VSITEMID -> VersionRange -> ProjectContent -> IO () setItemVersionRange itemid verRng content = do itemRef <- lookupProjectItem itemid content item <- readIORef itemRef case item of PackageItem{} -> do writeIORef itemRef item{itemVerRng=verRng} writeIORef (dirtyFlag content) True notifyPropertyChanged content itemid VSHPROPID_Caption _ -> return () setItemFileKind :: VSITEMID -> FileKind -> ProjectContent -> IO () setItemFileKind itemid fkind content = do itemRef <- lookupProjectItem itemid content item <- readIORef itemRef let updateFolderKind = do let item' = item{itemFKind=fkind} writeIORef itemRef item' writeIORef (dirtyFlag content) True mb_modName <- getModuleName item' "" case mb_modName of Just modName -> updateModuleNames modName itemRef content Nothing -> return () notifyPropertyChanged content itemid VSHPROPID_IconIndex updateFileKind = do writeIORef itemRef item{itemFKind=fkind} writeIORef (dirtyFlag content) True notifyPropertyChanged content itemid VSHPROPID_IconIndex case item of RootItem{itemFKind=HsSourceFolder} | fkind == PlainFolder -> updateFolderKind RootItem{itemFKind=PlainFolder} | fkind == HsSourceFolder-> updateFolderKind FileItem{itemFKind=ExposedModule} | fkind == HiddenModule -> updateFileKind FileItem{itemFKind=HiddenModule} | fkind == ExposedModule -> updateFileKind FolderItem{itemFKind=HsSourceFolder} | fkind == PlainFolder -> updateFolderKind FolderItem{itemFKind=PlainFolder} | fkind == HsSourceFolder-> updateFolderKind _ -> return () getItemFilePath :: VSITEMID -> FilePath -> ProjectContent -> IO FilePath getItemFilePath itemid projPath content = do item <- lookupProjectItem itemid content >>= readIORef loop item "" where loop NullItem path = return path loop (RootItem{}) path = return (projPath `joinFileName` path) loop item path = do parent <- readIORef (itemParent item) loop parent (itemName item `joinFileName` path) -- | The function returns the GHC.Module which correspond to the given -- itemid. Nothing is returned if this is a file which isn't in any of hsSourceDirs. getItemGHCModule :: VSITEMID -> ProjectContent -> IO (Maybe ModuleName) getItemGHCModule itemid content = do item <- lookupProjectItem itemid content >>= readIORef case item of FileItem{itemModule=ProjectModule{pmodModule=mdl}} -> return (Just mdl) _ -> return Nothing getItemAllGHCModules :: ProjectContent -> IO (Array Int (VSITEMID,ModuleName)) getItemAllGHCModules content = do (ProjectModules _ _ arr) <- readIORef (projModules content) return arr isFileInProject :: FilePath -> FilePath -> ProjectContent -> IO (Maybe VSITEMID) isFileInProject filename projPath content = do -- first strip off the projPath if necessary let nprojPath = normaliseFilename projPath nfilename = normaliseFilename filename stripped = case maybePrefixMatch nprojPath nfilename of Nothing -> filename Just rest -> dropWhile isPathSeparator rest if (null stripped) then return Nothing else findItem stripped (rootItemRef content) where -- recursively, with current item starting at root: -- - strip off ".\" -- - read up to directory separator -- - find the item with this name -- - continue until filename is empty findItem filename itemref = do item <- readIORef itemref let (name,rest) = splitPath filename -- case item of NullItem -> return Nothing RootItem{} -> findChildren filename item FolderItem{} | itemFKind item /= NPFile && name == itemName item -> findChildren rest item FileItem{} | itemFKind item /= NPFile && name == itemName item -> if null rest then return (Just (itemId item)) else return Nothing _ -> findItem filename (itemNext item) findChildren "" item = return (Just (itemId item)) findChildren filename item = findItem filename (itemChild item) -- strip the first component off a file path splitPath :: FilePath -> (String,FilePath) splitPath filename = if component == "." then splitPath rest else (component,rest) where (component,rest1) = break isPathSeparator filename rest = dropWhile isPathSeparator rest1 -- just upper-case the drive name normaliseFilename filename = case break (\c -> c==':') filename of (str,"") -> str (drive,file) -> map toUpper drive ++ file maybePrefixMatch :: String -> String -> Maybe String maybePrefixMatch [] rest = Just rest maybePrefixMatch (_:_) [] = Nothing maybePrefixMatch (p:pat) (r:rest) | p == r = maybePrefixMatch pat rest | otherwise = Nothing getNextItemID :: VSITEMID -> ProjectContent -> IO VSITEMID getNextItemID itemid content = do item <- lookupProjectItem itemid content >>= readIORef case item of NullItem -> return vSITEMID_NIL RootItem{} -> return vSITEMID_NIL item -> do item <- readIORef (itemNext item) case item of NullItem -> return vSITEMID_NIL item -> return (itemId item) getPrevItemID :: VSITEMID -> ProjectContent -> IO VSITEMID getPrevItemID itemid content = do item <- lookupProjectItem itemid content >>= readIORef case item of NullItem -> return vSITEMID_NIL RootItem{} -> return vSITEMID_NIL item -> do item <- readIORef (itemPrev item) case item of NullItem -> return vSITEMID_NIL item -> return (itemId item) getParentItemID :: VSITEMID -> ProjectContent -> IO VSITEMID getParentItemID itemid content = do item <- lookupProjectItem itemid content >>= readIORef case item of NullItem -> return vSITEMID_NIL RootItem{} -> return vSITEMID_NIL item -> do item <- readIORef (itemParent item) case item of NullItem -> return vSITEMID_ROOT item -> return (itemId item) getChildItemID :: VSITEMID -> ProjectContent -> IO VSITEMID getChildItemID itemid content = do item <- lookupProjectItem itemid content >>= readIORef case item of FileItem{} -> return vSITEMID_NIL PackageItem{} -> return vSITEMID_NIL _ -> do item <- readIORef (itemChild item) case item of NullItem -> return vSITEMID_NIL item -> return (itemId item) setItemTyThings :: VSITEMID -> ModuleInfo -> ProjectContent -> IO () setItemTyThings itemid mdlInfo content = do let scope = maybe emptyNameSet mkNameSet (GHC.modInfoTopLevelScope mdlInfo) tyThings' = GHC.modInfoTyThings mdlInfo tyThings = foldl (addDecl scope) [] tyThings' instances = modInfoInstances mdlInfo tlen = length tyThings ilen = length instances itemRef <- lookupProjectItem itemid content item <- readIORef itemRef case item of FileItem{itemModule=pmod@(ProjectModule{})} -> writeIORef itemRef item{itemModule=pmod{pmodTyThings = listArray (0,tlen-1) tyThings ,pmodInstances = listArray (tlen,tlen+ilen-1) instances ,pmodIsExported= modInfoIsExportedName mdlInfo ,pmodCounter1 = (pmodCounter1 pmod) + 1 }} _ -> return () where addDecl scope tyThings (AnId id) | isImplicitId id = tyThings | isDictonaryId id = tyThings | not (getName id `elemNameSet` scope) = tyThings addDecl scope tyThings (ADataCon _) = tyThings addDecl scope tyThings (ATyCon tyCon) | isClassTyCon tyCon = tyThings addDecl scope tyThings tyThing = tyThing : tyThings getItemTyThings :: VSITEMID -> ProjectContent -> IO (Array Int TyThing,Array Int Instance,Name -> Bool) getItemTyThings itemid content = do item <- lookupProjectItem itemid content >>= readIORef case item of FileItem{itemModule=ProjectModule{pmodTyThings = tyThings ,pmodInstances = instances ,pmodIsExported= isExported }} -> return (tyThings,instances,isExported) _ -> return (listArray (0,-1) [],listArray (0,-1) [],const False) getItemUpdateCounter :: VSITEMID -> ProjectContent -> IO (ULONG, VSTREELISTITEMCHANGE) getItemUpdateCounter itemid content = do itemRef <- lookupProjectItem itemid content item <- readIORef itemRef case item of FileItem{itemModule=pmod@(ProjectModule{pmodCounter1 = counter1 ,pmodCounter2 = counter2 })} -> do writeIORef itemRef item{itemModule=pmod{pmodCounter2=counter1}} let changesMask | counter1 == counter2 = TCT_NOCHANGE | otherwise = TCT_TOOMANYCHANGES return (counter1, (VSTREELISTITEMCHANGE (-1) changesMask)) _ -> return (0, (VSTREELISTITEMCHANGE (-1) TCT_NOCHANGE)) --------------------------------------------------------------------- -- Load/Save project content --------------------------------------------------------------------- extractPackageDescription :: ProjectContent -> IO PackageDescription extractPackageDescription content = do root <- readIORef (rootItemRef content) let (srcDepth,srcDirs) = case itemFKind root of HsSourceFolder -> ( 0,["."]) _ -> (-1, []) (exp_mods,hidden_mods,srcDirs,cfiles,tfiles,deps) <- collectFiles [] srcDepth [] [] srcDirs [] [] [] (rootItemRef content) writeIORef (dirtyFlag content) False metaInfo <- readIORef (projMetaInfo content) mainIs <- readIORef (projMainIs content) binfo <- readIORef (projBuildInfo content) licenseFileId <- readIORef (projLICENSE content) licenseFilePath <- getItemFilePath licenseFileId "." content let pkgDescr0 = emptyPackageDescription { package = PackageIdentifier {pkgName=itemName root, pkgVersion=itemVersion root} , license = miLicense metaInfo , licenseFile = licenseFilePath , copyright = miCopyright metaInfo , maintainer = miMaintainer metaInfo , author = miAuthor metaInfo , stability = miStability metaInfo , testedWith = miTestedWith metaInfo , homepage = miHomepage metaInfo , pkgUrl = miPkgURL metaInfo , synopsis = miSynopsis metaInfo , description = miDescription metaInfo , category = miCategory metaInfo , buildDepends= deps , extraSrcFiles=tfiles } pkgDescr | null mainIs = pkgDescr0{library=Just lib} | otherwise = pkgDescr0{executables=[exec]} where lib = Library { exposedModules = exp_mods , libBuildInfo = binfo{ otherModules=hidden_mods , cSources=cfiles , hsSourceDirs=srcDirs } } exec = Executable { exeName = itemName root , modulePath = mainIs , buildInfo = binfo{ otherModules=exp_mods++hidden_mods , cSources=cfiles , hsSourceDirs=srcDirs } } return pkgDescr where mkCabalPath [] fpath = fpath mkCabalPath (x:xs) fpath = mkCabalPath xs (x++'/':fpath) collectFiles path srcDepth exp_mods hidden_mods srcDirs cfiles tfiles deps itemRef = do item <- readIORef itemRef case item of RootItem{} -> collectFiles path srcDepth exp_mods hidden_mods srcDirs cfiles tfiles deps (itemChild item) FileItem{} -> let (_,modFPath,_) = splitFilePath (itemName item) modName = capFirstChar modFPath mkCabalName (x:xs) depth modName | depth > 0 = mkCabalName xs (depth-1) (capFirstChar x++'.':modName) mkCabalName _ _ modName = modName (exp_mods',hidden_mods',srcDirs',cfiles',tfiles') = case itemFKind item of ExposedModule | srcDepth >= 0 -- we are in hs-source directory -> (exp_mods++[mkCabalName path srcDepth modName],hidden_mods,srcDirs,cfiles,tfiles) HiddenModule | srcDepth >= 0 -- we are in hs-source directory -> (exp_mods,hidden_mods++[mkCabalName path srcDepth modName],srcDirs,cfiles,tfiles) CSource -> (exp_mods,hidden_mods,srcDirs,cfiles++[mkCabalPath path (itemName item)],tfiles) LicenseText -> (exp_mods,hidden_mods,srcDirs,cfiles,tfiles) -- it is in the license-file field SetupScript -> (exp_mods,hidden_mods,srcDirs,cfiles,tfiles) -- ignored NPFile -> (exp_mods,hidden_mods,srcDirs,cfiles,tfiles) -- ignored _ -> (exp_mods,hidden_mods,srcDirs,cfiles,tfiles++[mkCabalPath path (itemName item)]) in collectFiles path srcDepth exp_mods' hidden_mods' srcDirs' cfiles' tfiles' deps (itemNext item) FolderItem{} -> do let sub_path = itemName item : path (exp_mods',hidden_mods',srcDirs',cfiles',tfiles',deps') <- case itemFKind item of HsSourceFolder -> collectFiles sub_path 0 exp_mods hidden_mods (mkCabalPath path (itemName item):srcDirs) cfiles tfiles deps (itemChild item) PlainFolder -> let sub_depth | srcDepth >= 0 = srcDepth+1 | otherwise = srcDepth in collectFiles sub_path sub_depth exp_mods hidden_mods srcDirs cfiles tfiles deps (itemChild item) _ -> return (exp_mods,hidden_mods,srcDirs,cfiles,tfiles,deps) collectFiles path srcDepth exp_mods' hidden_mods' srcDirs' cfiles' tfiles' deps' (itemNext item) ReferencesItem{} -> do (exp_mods',hidden_mods',srcDirs',cfiles',tfiles',deps') <- collectFiles path srcDepth exp_mods hidden_mods srcDirs cfiles tfiles deps (itemChild item) collectFiles path srcDepth exp_mods' hidden_mods' srcDirs' cfiles' tfiles' deps' (itemNext item) PackageItem{}-> let deps' = deps++[Dependency (itemName item) (itemVerRng item)] in collectFiles path srcDepth exp_mods hidden_mods srcDirs cfiles tfiles deps' (itemNext item) NullItem -> return (exp_mods,hidden_mods,srcDirs,cfiles,tfiles,deps) capFirstChar (x:xs) = toUpper x : xs capFirstChar "" = "" getModuleName item@NullItem modname = return Nothing getModuleName item@(RootItem{itemFKind=HsSourceFolder}) modname = return (Just modname) getModuleName item@(RootItem{}) modname = return Nothing getModuleName item@(FileItem{itemFKind=kind}) modname | kind == ExposedModule || kind == HiddenModule = do parent <- readIORef (itemParent item) let (_,fileName,_) = splitFilePath (itemName item) getModuleName parent (capFirstChar fileName) | otherwise = return Nothing getModuleName item@(FolderItem{itemFKind=HsSourceFolder}) modname = return (Just modname) getModuleName item@(FolderItem{}) modname = do parent <- readIORef (itemParent item) getModuleName parent (capFirstChar (itemName item) ++ (if null modname then modname else '.':modname)) -- Notifications addHierarchyEventListener :: IVsHierarchyEvents () -> ProjectContent -> IO VSCOOKIE addHierarchyEventListener eventSink content = addEventListener (hierEvent content) eventSink removeHierarchyEventListener :: VSCOOKIE -> ProjectContent -> IO () removeHierarchyEventListener cookie content = removeEventListener (hierEvent content) cookie notifyItemAdded :: ProjectContent -> VSITEMID -> VSITEMID -> VSITEMID -> IO () notifyItemAdded content parent prev added = foreachEventListeners (hierEvent content) (onItemAdded parent prev added) notifyItemAppended :: ProjectContent -> VSITEMID -> IO () notifyItemAppended content parent = foreachEventListeners (hierEvent content) (onItemsAppended parent) notifyItemDeleted :: ProjectContent -> VSITEMID -> IO () notifyItemDeleted content itemid = foreachEventListeners (hierEvent content) (onItemDeleted itemid) notifyPropertyChanged :: ProjectContent -> VSITEMID -> VSHPROPID -> IO () notifyPropertyChanged content itemid propid = foreachEventListeners (hierEvent content) (onPropertyChanged itemid propid 0) notifyInvalidateItems :: ProjectContent -> VSITEMID -> IO () notifyInvalidateItems content parent = foreachEventListeners (hierEvent content) (onInvalidateItems parent)