{-# LANGUAGE DeriveDataTypeable #-} {-# LANGUAGE MultiParamTypeClasses #-} {-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE TypeSynonymInstances #-} {-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE RecordWildCards #-} {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE LambdaCase #-} {-# OPTIONS_GHC -fno-warn-warnings-deprecations #-} ----------------------------------------------------------------------------- -- -- Module : IDE.Pane.Workspace -- Copyright : 2007-2011 Juergen Nicklisch-Franken, Hamish Mackenzie -- License : GPL -- -- Maintainer : maintainer@leksah.org -- Stability : provisional -- Portability : -- -- | The pane of the IDE that shows the cabal packages in the workspace -- and their components, source dependencies and files -- ----------------------------------------------------------------------------- module IDE.Pane.Workspace ( WorkspaceState(..) , WorkspacePane(..) , getWorkspacePane , showWorkspacePane , refreshWorkspacePane , rebuildWorkspacePane ) where import Prelude hiding (catch) import Data.Maybe (fromJust, fromMaybe, maybeToList, listToMaybe, isJust, isNothing) import Control.Monad (forM, void, when) import Data.Foldable (forM_, for_) import Data.Typeable (Typeable) import IDE.Core.State (onIDE, catchIDE, window, getIDE, MessageLevel(..), ipdPackageId, wsPackages, workspace, readIDE, IDEAction, ideMessage, reflectIDE, reifyIDE, IDEM, IDEPackage) import IDE.Pane.SourceBuffer (selectSourceBuf, fileNew, goToSourceDefinition') import Control.Applicative ((<$>)) import System.FilePath ((), takeFileName, dropFileName, addTrailingPathSeparator, takeDirectory, takeExtension, makeRelative, splitDirectories) import Distribution.Package (PackageIdentifier(..)) import System.Directory (removeDirectoryRecursive, removeDirectory, createDirectory, doesFileExist, removeFile, doesDirectoryExist, getDirectoryContents, getPermissions, readable) import IDE.Core.CTypes (Location(..), packageIdentifierToString) import Graphics.UI.Frame.Panes (PaneMonad(..), RecoverablePane(..), PanePath, RecoverablePane, Pane(..)) import Graphics.UI.Frame.ViewFrame (getMainWindow, getNotebook) import Graphics.UI.Editor.Basics (Connection(..)) import Control.Monad.IO.Class (MonadIO(..)) import IDE.Utils.GUIUtils (showErrorDialog, showInputDialog, treeViewContextMenu', __, showDialogOptions, treeViewToggleRow) import Control.Exception (SomeException(..), catch) import Data.Text (Text) import qualified Data.Text as T (isPrefixOf, words, isSuffixOf, unpack, pack) import Data.Monoid ((<>)) import IDE.Core.Types (pjLookupPackage, wsLookupProject, pjPackages, activeComponent, activePack, activeProject, Project(..), ipdLib, WorkspaceAction, Workspace(..), wsAllPackages, WorkspaceM, runPackage, runProject, runWorkspace, PackageAction, PackageM, ProjectAction, ProjectM, IDEPackage(..), IDE(..), Prefs(..), MonadIDE(..), ipdPackageDir) import Control.Monad.Reader.Class (MonadReader(..)) import IDE.Workspaces (workspaceOpen, makePackage, projectAddPackage', workspaceRemoveProject, projectRemovePackage, workspaceActivatePackage, workspaceTry, workspaceTryQuiet, packageTry) import Data.List (sortOn, isSuffixOf, find, stripPrefix, isPrefixOf, sortBy, sort) import Data.Ord (comparing) import Data.Char (toUpper, toLower) import System.Log.Logger (errorM, debugM) import Data.Tree (Forest, Tree(..)) import IDE.Pane.Modules (addModule) import IDE.Pane.PackageEditor (packageEditText, projectEditText) import IDE.Package (packageTest, packageRun, packageClean,packageBench) import Control.Monad.Trans.Class (MonadTrans(..)) import Data.GI.Gtk.ModelView.ForestStore (forestStoreGetTree, forestStoreGetValue, ForestStore(..), forestStoreRemove, forestStoreInsert, forestStoreSetValue, forestStoreClear, forestStoreNew) import GI.Gtk.Structs.TreeIter (treeIterCopy, TreeIter(..)) import Data.GI.Gtk.ModelView.TreeModel (treeModelIterNext, treeModelIterNthChild, treeModelGetIter, treeModelGetPath) import GI.Gtk.Structs.TreePath (TreePath(..)) import GI.Gtk.Objects.ScrolledWindow (scrolledWindowSetPolicy, scrolledWindowSetShadowType, scrolledWindowNew, ScrolledWindow(..)) import GI.Gtk.Objects.TextView (textViewSetEditable, textViewNew, TextView(..)) import GI.Pango.Structs.FontDescription (fontDescriptionSetFamily, fontDescriptionNew, fontDescriptionFromString) import GI.Gtk.Objects.TreeView (treeViewRowExpanded, onTreeViewRowActivated, onTreeViewRowExpanded, treeViewGetSelection, treeViewSetHeadersVisible, treeViewAppendColumn, treeViewSetModel, treeViewNew, TreeView(..)) import GI.Gtk.Objects.Widget (widgetHide, widgetShowAll, afterWidgetFocusInEvent, toWidget, widgetOverrideFont) import GI.Gtk.Objects.TreeViewColumn (treeViewColumnSetReorderable, treeViewColumnSetResizable, treeViewColumnSetSizing, treeViewColumnNew) import GI.Gtk.Enums (PackType(..), PackType, Orientation(..), MessageType(..), PolicyType(..), ShadowType(..), TreeViewColumnSizing(..)) import GI.Gtk.Objects.CellRendererPixbuf (setCellRendererPixbufStockId, cellRendererPixbufNew) import GI.Gtk.Interfaces.CellLayout (cellLayoutPackStart) import Data.GI.Base (set) import Data.GI.Gtk.ModelView.CellLayout (cellLayoutSetDataFunc', cellLayoutSetDataFunction) import GI.Gtk.Objects.CellRendererText (setCellRendererTextMarkup, cellRendererTextNew) import GI.Gtk.Objects.Adjustment (noAdjustment) import GI.Gtk.Objects.Container (containerRemove, containerAdd) import Data.GI.Gtk.ModelView.CustomStore (customStoreGetRow) import Data.Int (Int32) import Data.GI.Gtk.ModelView.Types (treePathGetIndices', treePathNewFromIndices') import VCSWrapper.Git.Safe as Git import GI.Gtk.Objects.Box (boxSetChildPacking, boxPackStart, boxNew, Box(..)) import Data.GI.Base.GObject (new') import GI.Gtk.Objects.Label (Label(..), labelNew) import Graphics.UI.Editor.Parameters (Packing(..), boxPackStart') import GI.Gtk.Objects.LinkButton (onLinkButtonActivateLink, linkButtonNewWithLabel, LinkButton(..), linkButtonNew) import Data.GI.Base.Signals (SignalHandlerId) import GI.Gtk (treeViewExpandRow) -- | The data for a single record in the Workspace Pane data WorkspaceRecord = FileRecord FilePath | DirRecord FilePath Bool -- Whether it is a source directory | ProjectRecord FilePath | PackageRecord FilePath | ComponentsRecord | ComponentRecord Text | GitRecord deriving (Eq, Show) instance Ord WorkspaceRecord where -- | The ordering used for displaying the records compare (DirRecord _ _) (FileRecord _) = LT compare (FileRecord _) (DirRecord _ _) = GT compare (FileRecord p1) (FileRecord p2) = comparing (map toLower) p1 p2 compare (DirRecord p1 _) (DirRecord p2 _) = comparing (map toLower) p1 p2 compare (ProjectRecord p1) (ProjectRecord p2) = comparing (map toLower) p1 p2 compare (PackageRecord p1) (PackageRecord p2) = comparing (map toLower) p1 p2 compare (ComponentRecord t1) (ComponentRecord t2) = comparing (map toLower . T.unpack) t1 t2 compare _ _ = LT -- | The markup to show for a record toMarkup :: WorkspaceRecord -> (Maybe Project, Maybe IDEPackage) -> IDEM Text toMarkup record (mbProject, mbPackage) = readIDE workspace >>= \case Nothing -> return "Error Workspace Closed" Just ws -> do mbActiveProject <- readIDE activeProject mbActivePackage <- readIDE activePack mbActiveComponent <- readIDE activeComponent let worspaceRelative = makeRelative (dropFileName (wsFile ws)) projectRelative = case mbProject of Just p -> makeRelative (dropFileName (pjFile p)) Nothing -> id activeProject = (pjFile <$> mbProject) == (pjFile <$> mbActiveProject) activePackage = activeProject && (ipdCabalFile <$> mbPackage) == (ipdCabalFile <$> mbActivePackage) case record of (ProjectRecord p) -> return $ (if activeProject then bold else id) (T.pack $ worspaceRelative p) (PackageRecord pFile) -> return $ case mbPackage of Nothing -> "Error package not found " <> T.pack pFile Just p -> let pkgText = (if activePackage then bold else id) (packageIdentifierToString (ipdPackageId p)) mbLib = ipdLib p componentText = if activePackage then maybe (if isJust mbLib then "(library)" else "") (\comp -> "(" <> comp <> ")") mbActiveComponent else "" pkgDir = gray . T.pack . projectRelative $ ipdPackageDir p in (pkgText <> " " <> componentText <> " " <> pkgDir) (FileRecord f) -> return $ T.pack $ takeFileName f (DirRecord f _) | (ipdPackageDir <$> mbPackage) == Just f -> return "Files" | otherwise -> return $ T.pack $ last (splitDirectories f) ComponentsRecord -> return "Components" (ComponentRecord comp) -> do let active = activePackage && (isNothing mbActiveComponent && comp == "library" || Just comp == mbActiveComponent) return $ (if active then bold else id) comp GitRecord -> case ipdPackageDir <$> mbPackage of Nothing -> return "No Git project" Just dir -> do let conf = Git.makeConfig (Just dir) Nothing Nothing liftIO $ Git.runVcs conf $ do branch <- Git.localBranches case branch of (Right (branch,_)) -> return branch (Left _) -> return "No Git project" where bold str = "" <> str <> "" italic str = "" <> str <> "" gray str = "" <> str <> "" -- | The icon to show for a record toIcon :: WorkspaceRecord -> Text toIcon record = case record of FileRecord path | takeExtension path == ".hs" -> "ide_source" | takeExtension path == ".cabal" -> "ide_cabal_file" DirRecord p isSrc | isSrc -> "ide_source_folder" | otherwise -> "ide_folder" ProjectRecord _ -> "ide_source_dependency" PackageRecord _ -> "ide_package" ComponentsRecord -> "ide_component" GitRecord -> "ide_git" _ -> "" -- | Gets the package to which a node in the tree belongs iterToPackage :: ForestStore WorkspaceRecord -> TreeIter -> IDEM (Maybe Project, Maybe IDEPackage) iterToPackage store iter = do path <- treeModelGetPath store iter treePathToPackage store path -- | Gets the package to which a node in the tree belongs treePathToPackage :: ForestStore WorkspaceRecord -> TreePath -> IDEM (Maybe Project, Maybe IDEPackage) treePathToPackage store p = treePathGetIndices' p >>= treePathToPackage' store treePathToPackage' :: ForestStore WorkspaceRecord -> [Int32] -> IDEM (Maybe Project, Maybe IDEPackage) treePathToPackage' store (n1:n2:_) = do projectRecord <- forestStoreGetValue store =<< treePathNewFromIndices' [n1] packageRecord <- forestStoreGetValue store =<< treePathNewFromIndices' [n1,n2] case (projectRecord, packageRecord) of (ProjectRecord pjFile, PackageRecord pkgFile) -> readIDE workspace >>= \case Just ws -> case wsLookupProject pjFile ws of Just pj -> case pjLookupPackage pkgFile pj of Just pkg -> return (Just pj, Just pkg) _ -> do liftIO . errorM "leksah" $ "treePathToPackage: could not find pakcage " <> pkgFile return (Nothing, Nothing) _ -> do liftIO . errorM "leksah" $ "treePathToPackage: Could not find project " <> pjFile return (Nothing, Nothing) _ -> do liftIO $ errorM "leksah" "treePathToPackage: No workspace" return (Nothing, Nothing) _ -> do liftIO $ errorM "leksah" "treePathToPackage: Unexpected entry in forest" return (Nothing, Nothing) treePathToPackage' store (n:_) = treePathNewFromIndices' [n] >>= forestStoreGetValue store >>= \case ProjectRecord pjFile -> readIDE workspace >>= \case Just ws -> case wsLookupProject pjFile ws of Just pj -> return (Just pj, Nothing) _ -> do liftIO . errorM "leksah" $ "treePathToPackage: Could not find project " <> pjFile return (Nothing, Nothing) _ -> do liftIO $ errorM "leksah" "treePathToPackage: No workspace" return (Nothing, Nothing) _ -> do liftIO $ debugM "leksah" "treePathToPackage: Unexpected entry at root forest" return (Nothing, Nothing) treePathToPackage' _ _ = do liftIO $ debugM "leksah" "treePathToPackage is called with empty path" return (Nothing, Nothing) -- | Determines whether the 'WorkspaceRecord' can expand, i.e. whether -- it should get an expander. canExpand :: WorkspaceRecord -> Project -> Maybe IDEPackage -> IDEM Bool canExpand record pj mbPkg = case record of (ProjectRecord _) -> return False (PackageRecord _) -> return True (DirRecord fp _) -> do mbWs <- readIDE workspace case mbWs of Just ws -> not . null <$> ((`runWorkspace` ws) . (`runProject` pj) . (`runPackage` pkg) $ dirRecords fp) Nothing -> return False ComponentsRecord -> return . not . null $ components _ -> return False where components = maybeToList (ipdLib pkg) ++ ipdExes pkg ++ ipdTests pkg ++ ipdBenchmarks pkg pkg = fromJust mbPkg -- Only for record trypes that should have a package (not ProjectRecord) -- * The Workspace pane -- | The representation of the Workspace pane data WorkspacePane = WorkspacePane { box :: Box , scrolledView :: ScrolledWindow , noWsText :: LinkButton , treeView :: TreeView , recordStore :: ForestStore WorkspaceRecord } deriving Typeable -- | The additional state used when recovering the pane -- (none) data WorkspaceState = WorkspaceState deriving(Eq,Ord,Read,Show,Typeable) instance Pane WorkspacePane IDEM where primPaneName _ = __ "Workspace" getAddedIndex _ = 0 getTopWidget = liftIO . toWidget . box paneId b = "*Workspace" instance RecoverablePane WorkspacePane WorkspaceState IDEM where saveState p = return (Just WorkspaceState) recoverState pp WorkspaceState = do nb <- getNotebook pp buildPane pp nb builder builder pp nb windows = do ideR <- ask recordStore <- forestStoreNew [] -- Treeview treeView <- buildTreeView recordStore sigIds <- treeViewEvents recordStore treeView -- Scrolled view scrolledView <- scrolledWindowNew noAdjustment noAdjustment scrolledWindowSetShadowType scrolledView ShadowTypeIn scrolledWindowSetPolicy scrolledView PolicyTypeAutomatic PolicyTypeAutomatic containerAdd scrolledView treeView -- "Open workspace" link noWsText <- linkButtonNewWithLabel "Open a workspace" (Just "Open a workspace") onLinkButtonActivateLink noWsText $ do reflectIDE workspaceOpen ideR return False -- Box, top-level widget of the pane box <- boxNew OrientationVertical 0 boxPackStart box scrolledView False True 0 boxPackStart box noWsText True True 0 -- Calling refreshWorkspacePane here does not work -- since the GUI is not yet running. This created strange behaviour -- where the workspace was split evenly while only one of the -- widgets (ScrolledView/TreeView and Openworkspace link). -- Instead we initialize the packing of the TreeView to not expand -- and rely on the fact that refreshWorkspacePane is called -- by the WorkspaceChanged event, and the packing of the two -- widgets is changed there when swapping. let wsPane = WorkspacePane {..} return (Just wsPane, sigIds) buildTreeView :: ForestStore WorkspaceRecord -> IDEM TreeView buildTreeView recordStore = do treeView <- treeViewNew treeViewSetModel treeView (Just recordStore) col1 <- treeViewColumnNew treeViewColumnSetSizing col1 TreeViewColumnSizingAutosize treeViewColumnSetResizable col1 True treeViewColumnSetReorderable col1 True treeViewAppendColumn treeView col1 prefs <- readIDE prefs when (showWorkspaceIcons prefs) $ do renderer2 <- cellRendererPixbufNew cellLayoutPackStart col1 renderer2 False setCellRendererPixbufStockId renderer2 "" cellLayoutSetDataFunction col1 renderer2 recordStore $ setCellRendererPixbufStockId renderer2 . toIcon renderer1 <- cellRendererTextNew ideR <- ask cellLayoutPackStart col1 renderer1 True cellLayoutSetDataFunc' col1 renderer1 recordStore $ \iter -> do record <- customStoreGetRow recordStore iter projAndPkg <- (`reflectIDE` ideR) $ iterToPackage recordStore iter -- The cellrenderer is stateful, so it knows which cell this markup will be for (the cell at iter) markup <- (`reflectIDE` ideR) $ toMarkup record projAndPkg setCellRendererTextMarkup renderer1 markup -- set workspace font mbFd <- case workspaceFont prefs of (True, Just str) -> Just <$> fontDescriptionFromString str _ -> return Nothing widgetOverrideFont treeView mbFd -- treeViewSetActiveOnSingleClick treeView True treeViewSetHeadersVisible treeView False sel <- treeViewGetSelection treeView -- treeSelectionSetMode sel SelectionModeSingle return treeView treeViewEvents :: ForestStore WorkspaceRecord -> TreeView -> IDEM [Connection] treeViewEvents recordStore treeView = do ideR <- ask cid1 <- onTreeViewRowExpanded treeView $ \iter path -> do record <- forestStoreGetValue recordStore path (`reflectIDE` ideR) $ iterToPackage recordStore iter >>= \case (Just project, Just pkg) -> workspaceTryQuiet . (`runProject` project) $ refreshPackageTreeFrom recordStore treeView path _ -> return () cid2 <- onTreeViewRowActivated treeView $ \path col -> do record <- forestStoreGetValue recordStore path (`reflectIDE` ideR) $ treePathToPackage recordStore path >>= \case (Just project, mbPkg) -> do expandable <- canExpand record project mbPkg case record of ProjectRecord project -> void $ selectSourceBuf project FileRecord f -> void $ goToSourceDefinition' f (Location "" 1 0 1 0) ComponentRecord name -> workspaceTryQuiet $ workspaceActivatePackage project mbPkg (Just name) _ -> when expandable $ void $ treeViewToggleRow treeView path _ -> return () sigIds <- treeViewContextMenu' treeView recordStore contextMenuItems return $ sigIds <> map (ConnectC treeView) [cid1, cid2] -- | Get the Workspace pane getWorkspacePane :: IDEM WorkspacePane getWorkspacePane = forceGetPane (Right "*Workspace") -- | Show the Workspace pane showWorkspacePane :: IDEAction showWorkspacePane = do l <- getWorkspacePane displayPane l False -- | Deletes the Workspace pane and rebuilds it (used when enabling/disabling -- icons, since it requires extra/fewer cellrenderers) rebuildWorkspacePane :: IDEAction rebuildWorkspacePane = do mbWsPane <- getPane :: IDEM (Maybe WorkspacePane) forM_ mbWsPane closePane getOrBuildPane (Right "*Workspace") :: IDEM (Maybe WorkspacePane) return () -- | Searches the workspace packages if it is part of any of them fileGetPackage :: FilePath -> WorkspaceM (Maybe IDEPackage) fileGetPackage path = do packages <- wsAllPackages <$> ask let dirs = [p | p <- packages, takeDirectory (ipdCabalFile p) `isPrefixOf` path] return (listToMaybe dirs) -- * Actions for refreshing the Workspace pane -- | Refreshes the Workspace pane, lists all packages and synchronizes the expanded -- nodes with the file system and workspace refreshWorkspacePane :: IDEAction refreshWorkspacePane = do liftIO $ debugM "leksah" "refreshWorkspacePane" workspace <- getWorkspacePane refresh workspace -- | Seperately defined from refreshWorkspacePane, since getWorkspacePane does not -- work before the building is finished refresh :: WorkspacePane -> IDEAction refresh WorkspacePane{..} = do mbWs <- readIDE workspace -- Depending on if there is a workspace, show the tree or a message to open one case mbWs of Nothing -> do widgetHide scrolledView boxSetChildPacking box scrolledView False False 0 PackTypeStart widgetShowAll noWsText boxSetChildPacking box noWsText True True 0 PackTypeStart Just ws -> do widgetHide noWsText boxSetChildPacking box noWsText False False 0 PackTypeStart widgetShowAll scrolledView boxSetChildPacking box scrolledView True True 0 PackTypeStart let projects = wsProjects ws forestStoreClear recordStore (`runWorkspace` ws) $ do path <- liftIO $ treePathNewFromIndices' [] for_ (zip [0..] projects) $ \(n, project) -> do liftIO $ forestStoreInsert recordStore path n (ProjectRecord $ pjFile project) let packages = pjPackages project (`runProject` project) $ do path <- liftIO $ treePathNewFromIndices' [fromIntegral n] for_ (zip [0..] packages) $ \(nPkg, pkg) -> do liftIO $ forestStoreInsert recordStore path nPkg (PackageRecord $ ipdCabalFile pkg) children <- children (PackageRecord $ ipdCabalFile pkg) (Just pkg) lift $ setChildren (Just project) (Just pkg) recordStore treeView [fromIntegral n, fromIntegral nPkg] children treeViewExpandRow treeView path False -- | Mutates the 'ForestStore' with the given TreePath as root to attach new -- entries to. Walks the directory tree recursively when refreshing directories. refreshPackageTreeFrom :: ForestStore WorkspaceRecord -> TreeView -> TreePath -> ProjectAction refreshPackageTreeFrom store view path = do record <- liftIO $ forestStoreGetValue store path (Just project, mbPkg) <- liftIDE $ treePathToPackage store path expandable <- liftIDE $ canExpand record project mbPkg kids <- children record mbPkg path' <- treePathGetIndices' path lift $ setChildren (Just project) mbPkg store view path' kids -- | Returns the children of the 'WorkspaceRecord'. children :: WorkspaceRecord -> Maybe IDEPackage -> ProjectM [WorkspaceRecord] children record mbPkg = case record of DirRecord dir _ -> runPkg $ dirRecords dir ComponentsRecord -> runPkg componentsRecords ProjectRecord project -> readIDE workspace >>= \case Nothing -> return [] Just ws -> return $ maybe [] (map (PackageRecord . ipdCabalFile) . pjPackages) $ wsLookupProject project ws PackageRecord pkg -> do p <- runPkg ask return [ ComponentsRecord , GitRecord , DirRecord (ipdPackageDir p) False] _ -> return [] where runPkg = (`runPackage` fromJust mbPkg) -- | Returns the contents at the given 'FilePath' as 'WorkspaceRecord's. -- Runs in the PackageM monad to determine if directories are -- source directories (as specified in the cabal file) dirRecords :: FilePath -> PackageM [WorkspaceRecord] dirRecords dir = do prefs <- readIDE prefs contents <- liftIO $ getDirectoryContents dir `catch` \(e :: IOError) -> return [] let filtered = if showHiddenFiles prefs then filter (`notElem` [".", ".."]) contents else filter ((/= '.') . head) contents records <- forM filtered $ \f -> do let full = dir f isDir <- liftIO $ doesDirectoryExist full if isDir then do -- find out if it is a source directory of the project pkgDir <- (addTrailingPathSeparator . takeDirectory . ipdCabalFile) <$> ask case stripPrefix pkgDir full of Just relativeToPackage -> do srcDirs <- ipdSrcDirs <$> ask return $ DirRecord full (relativeToPackage `elem` srcDirs) Nothing -> -- It's not a descendant of the package directory (e.g. in a source dependency) return $ DirRecord full False else return $ FileRecord full return (sort records) -- | Get the components for a specific package componentsRecords :: PackageM [WorkspaceRecord] componentsRecords = do package <- ask mbActivePackage <- readIDE activePack activeComponent <- readIDE activeComponent return $ sort $ map ComponentRecord (components package) where components package = map ("lib:"<>) (maybeToList (ipdLib package)) ++ map ("exe:"<>) (ipdExes package) ++ map ("test:"<>) (ipdTests package) ++ map ("bench:"<>) (ipdBenchmarks package) -- | Recursively sets the children of the given 'TreePath' to the provided tree of 'WorkspaceRecord's. If a record -- is already present, it is kept in the same (expanded) state. -- If a the parent record is not expanded just makes sure at least one of -- the children is added. setChildren :: Maybe Project -> Maybe IDEPackage -> ForestStore WorkspaceRecord -> TreeView -> [Int32] -> [WorkspaceRecord] -> WorkspaceAction setChildren _ _ store _ [] [] = liftIO $ forestStoreClear store setChildren mbProject mbPkg store view parentPath kids = do ws <- ask -- We only need to get all the children right when they are visible expanded <- if null parentPath then return True else liftIO $ treeViewRowExpanded view =<< treePathNewFromIndices' parentPath let kidsToAdd = (if expanded then id else take 1) kids forM_ (zip [0..] kidsToAdd) $ \(n, record) -> do liftIO $ do mbChildIter <- (treeModelGetIter store =<< treePathNewFromIndices' parentPath) >>= \case Just parentIter -> treeModelIterNthChild store (Just parentIter) n >>= \case (True, childIter) -> return (Just childIter) (False, _) -> return Nothing Nothing -> return Nothing let compare rec1 rec2 = case (rec1, rec2) of (ProjectRecord p1, ProjectRecord p2) -> p1 == p2 (PackageRecord p1, PackageRecord p2) -> p1 == p2 _ -> rec1 == rec2 findResult <- searchToRight compare record store mbChildIter case (mbChildIter, findResult) of (_, WhereExpected iter) -> do -- it's already there path <- treeModelGetPath store iter forestStoreSetValue store path record (Just iter, Found _) -> do -- it's already there at a later sibling path <- treeModelGetPath store iter removeUntil record store path _ -> do parentPath' <- treePathNewFromIndices' parentPath forestStoreInsert store parentPath' (fromIntegral n) record let project = case record of ProjectRecord p -> fromJust $ wsLookupProject p ws _ -> fromJust mbProject mbPkg' = case record of PackageRecord p -> pjLookupPackage p project _ -> mbPkg -- Only update the grand kids if they are visible when expanded $ do grandKids <- (`runProject` project) $ children record mbPkg' setChildren (Just project) mbPkg' store view (parentPath ++ [n]) grandKids liftIO $ if null kids then forestStoreRemoveChildren store parentPath else when expanded . void $ removeRemaining store =<< treePathNewFromIndices' (parentPath++[fromIntegral $ length kids]) -- * Context menu contextMenuItems :: WorkspaceRecord -> TreePath -> ForestStore WorkspaceRecord -> IDEM [[(Text, IDEAction)]] contextMenuItems record path store = do mainWindow <- getMainWindow case record of (FileRecord fp) -> do let onDeleteFile = flip catchIDE (\(e :: SomeException) -> print e) $ reifyIDE $ \ideRef -> showDialogOptions (Just mainWindow) ("Are you sure you want to delete " <> T.pack (takeFileName fp) <> "?") MessageTypeQuestion [ ("Delete File", removeFile fp >> reflectIDE refreshWorkspacePane ideRef) , ("Cancel", return ()) ] (Just 0) return [[("Open File...", void $ goToSourceDefinition' fp (Location "" 1 0 1 0))] ,[("Delete File...", onDeleteFile)]] DirRecord fp _ -> do let onNewModule = flip catchIDE (\(e :: SomeException) -> print e) $ treePathToPackage store path >>= \case (Just project, Just pkg) -> do mbWs <- readIDE workspace forM_ mbWs $ \ws -> do (`runWorkspace` ws) . (`runProject` project) . (`runPackage` pkg) $ do mbModulePath <- dirToModulePath fp let modulePrefix = fromMaybe [] mbModulePath addModule modulePrefix refreshWorkspacePane _ -> return () let onNewTextFile = flip catchIDE (\(e :: SomeException) -> print e) $ reifyIDE $ \ideRef -> do mbText <- showInputDialog (Just mainWindow) "File name:" "" case mbText of Just t -> do let path = fp T.unpack t exists <- doesFileExist path if exists then showErrorDialog (Just mainWindow) "File already exists" else do writeFile path "" void $ reflectIDE (refreshWorkspacePane >> goToSourceDefinition' path (Location "" 1 0 1 0)) ideRef Nothing -> return () let onNewDir = flip catchIDE (\(e :: SomeException) -> print e) $ reifyIDE $ \ideRef -> do mbText <- showInputDialog (Just mainWindow) "Directory name:" "" case mbText of Just t -> do let path = fp T.unpack t exists <- doesDirectoryExist path if exists then showErrorDialog (Just mainWindow) "Directory already exists" else do createDirectory path void $ reflectIDE refreshWorkspacePane ideRef Nothing -> return () let onDeleteDir = flip catchIDE (\(e :: SomeException) -> print e) $ reifyIDE $ \ideRef -> showDialogOptions (Just mainWindow) ("Are you sure you want to delete " <> T.pack (takeFileName fp) <> "?") MessageTypeQuestion [ ("Delete directory", removeDirectoryRecursive fp >> reflectIDE refreshWorkspacePane ideRef) , ("Cancel", return ()) ] (Just 0) return [ [ ("New Module...", onNewModule) , ("New Text File...", onNewTextFile) , ("New Directory...", onNewDir) ] , [ ("Delete Directory...", onDeleteDir) ] ] ProjectRecord projectFile -> do let onSetActive = workspaceTryQuiet $ do ws <- ask case wsLookupProject projectFile ws of Just project -> workspaceActivatePackage project Nothing Nothing Nothing -> liftIO . errorM "leksah" $ "onSetActive: Project not found " <> projectFile onOpenProjectFile = void $ selectSourceBuf projectFile onRemoveFromWs = workspaceTryQuiet $ do workspaceRemoveProject projectFile liftIDE refreshWorkspacePane return [ [ ("Set As Active Project", onSetActive) , ("Open Project File", onOpenProjectFile) ] , [ ("Remove From Workspace", onRemoveFromWs) ] ] PackageRecord _ -> treePathToPackage store path >>= \case (Just project, Just p) -> do let runPkg = (`runProject` project) . (`runPackage` p) onSetActive = workspaceTryQuiet $ workspaceActivatePackage project (Just p) Nothing onAddModule = workspaceTryQuiet $ runPkg $ addModule [] onOpenCabalFile = void . selectSourceBuf $ ipdCabalFile p onRemoveFromProject = workspaceTryQuiet . (`runProject` project) $ do projectRemovePackage p liftIDE refreshWorkspacePane return [ [ ("New Module...", onAddModule) , ("Set As Active Package", onSetActive) ] , [ ("Build", workspaceTryQuiet $ runPkg makePackage) , ("Run", workspaceTryQuiet $ runPkg packageRun) , ("Test", workspaceTryQuiet $ runPkg packageTest) , ("Benchmark", workspaceTryQuiet $ runPkg packageBench) , ("Clean", workspaceTryQuiet $ runPkg packageClean) , ("Open Package File", onOpenCabalFile) ] , [ ("Remove From Project", onRemoveFromProject) ] ] _ -> return [] ComponentRecord comp -> do (Just project, Just pkg) <- treePathToPackage store path let onSetActive = workspaceTryQuiet $ workspaceActivatePackage project (Just pkg) (Just comp) return [[ ("Activate component", onSetActive) ]] _ -> return [] -- | Searches the source folders to determine what the corresponding -- module path is dirToModulePath :: FilePath -> PackageM (Maybe [Text]) dirToModulePath fp = do pkgDir <- ipdPackageDir <$> ask srcDirs <- map (pkgDir <>) . ipdSrcDirs <$> ask return $ do srcDir <- find (`isPrefixOf` fp) srcDirs let suffix = if srcDir == fp then "" else makeRelative srcDir fp let dirs = map (T.pack . capitalize) (splitDirectories suffix) return dirs where capitalize (x:xs) = toUpper x : xs capitalize [] = [] -- * Utility functions for operating on 'ForestStore' leaf :: a -> Tree a leaf x = Node x [] forestStoreRemoveChildren :: ForestStore a -> [Int32] -> IO () forestStoreRemoveChildren store path = do Node record children <- forestStoreGetTree store =<< treePathNewFromIndices' path forM_ (zip [0..] children) $ \_ -> forestStoreRemove store =<< treePathNewFromIndices' (path ++ [0]) -- this works because mutation ... data FindResult = WhereExpected TreeIter | Found TreeIter | NotFound -- | Tries to find the given value in the 'ForestStore'. Only looks at the given 'TreeIter' and its -- sibling nodes to the right. -- Returns @WhereExpected iter@ if the records is found at the provided 'TreeIter' -- Returns @Found iter@ if the record is found at a sibling iter -- Returns @NotFound@ otherwise searchToRight :: (a -> a -> Bool) -> a -> ForestStore a -> Maybe TreeIter -> IO FindResult searchToRight compare _ _ Nothing = return NotFound searchToRight compare a store (Just iter) = do row <- customStoreGetRow store iter if compare row a then return $ WhereExpected iter else do next <- treeIterCopy iter treeModelIterNext store next >>= find' next where find' :: TreeIter -> Bool -> IO FindResult find' _ False = return NotFound find' iter True = do row <- customStoreGetRow store iter if compare row a then return $ Found iter else do next <- treeIterCopy iter treeModelIterNext store next >>= find' next -- | Starting at the node at the given 'TreePath', removes all sibling nodes to the right -- until the given value is found. removeUntil :: Eq a => a -> ForestStore a -> TreePath -> IO () removeUntil a store path = do row <- forestStoreGetValue store path when (row /= a) $ do found <- forestStoreRemove store path when found $ removeUntil a store path -- | Starting at the node at the given 'TreePath', removes all sibling nodes to the right removeRemaining :: ForestStore a -> TreePath -> IO () removeRemaining store path = do found <- forestStoreRemove store path when found $ removeRemaining store path