leksah-0.15.2.0: src/IDE/Pane/Workspace.hs
{-# LANGUAGE DeriveDataTypeable #-}
{-# LANGUAGE MultiParamTypeClasses #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE TypeSynonymInstances #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE RecordWildCards #-}
{-# LANGUAGE OverloadedStrings #-}
-----------------------------------------------------------------------------
--
-- 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 Graphics.UI.Gtk
(treeSelectionSelectIter, treeStoreLookup,
cellLayoutSetAttributeFunc, treeViewRowActivated, treeStoreClear,
treeModelGetIterFirst, treeViewLevelIndentation,
treeViewShowExpanders, treeViewCollapseRow, treeViewExpandRow,
treeSelectionUnselectAll, cellLayoutPackEnd, cellTextMarkup,
cellPixbufStockId, scrolledWindowSetShadowType,
treeSelectionSelectionChanged, treeStoreRemove, treeModelIterNext,
treeModelGetRow, treeStoreInsert, treeModelIterNthChild,
treeModelGetPath, TreeIter, treeModelGetIter, TreePath,
treeSelectionGetSelectedRows, rowActivated, treeStoreGetValue,
rowExpanded, on, after, focusInEvent, scrolledWindowSetPolicy,
containerAdd, scrolledWindowNew, treeSelectionSetMode,
treeViewGetSelection, treeViewSetHeadersVisible, cellText,
cellLayoutSetAttributes, cellLayoutPackStart, treeViewAppendColumn,
treeViewColumnSetReorderable, treeViewColumnSetResizable,
treeViewColumnSetSizing, treeViewColumnSetTitle, treeViewColumnNew,
cellRendererPixbufNew, cellRendererTextNew, treeViewSetModel,
treeViewNew, treeStoreNew, castToWidget, TreeStore, TreeView,
ScrolledWindow, treeViewRowExpanded, treeStoreGetTree, Menu(..),
MenuItem(..), treeStoreSetValue)
import Data.Maybe
(fromJust, fromMaybe, maybeToList, listToMaybe, isJust)
import Control.Monad (forM, void, when)
import Data.Foldable (forM_)
import Data.Typeable (Typeable)
import IDE.Core.State
(catchIDE, window, getIDE, MessageLevel(..), ipdPackageId,
wsPackages, workspace, readIDE, IDEAction, ideMessage, reflectIDE,
reifyIDE, IDEM, IDEPackage, ipdSandboxSources)
import IDE.Pane.SourceBuffer (fileNew, goToSourceDefinition')
import IDE.Sandbox
import Control.Applicative ((<$>))
import System.FilePath ((</>), takeFileName, dropFileName)
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
(RecoverablePane(..), PanePath, RecoverablePane, Pane(..))
import Graphics.UI.Frame.ViewFrame (getMainWindow, getNotebook)
import Graphics.UI.Editor.Basics (Connection(..))
import Graphics.UI.Gtk.General.Enums
(ShadowType(..), PolicyType(..), SelectionMode(..),
TreeViewColumnSizing(..))
import System.Glib.Attributes (set, AttrOp(..))
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
(ipdLib, WorkspaceAction, Workspace(..), wsAllPackages, WorkspaceM,
runPackage, runWorkspace, PackageAction, PackageM, IDEPackage(..),
IDE(..), Prefs(..), MonadIDE(..), ipdPackageDir)
import System.Glib.Properties (newAttrFromMaybeStringProperty)
import System.FilePath
(addTrailingPathSeparator, takeDirectory, takeExtension,
makeRelative, splitDirectories)
import Control.Monad.Reader.Class (MonadReader(..))
import IDE.Workspaces
(makePackage, workspaceAddPackage', workspaceRemovePackage,
workspaceActivatePackage, workspaceTry, workspaceTryQuiet,
packageTry)
import Data.List
(isSuffixOf, find, stripPrefix, isPrefixOf, sortBy, sort)
import Data.Ord (comparing)
import Data.Char (toUpper, toLower)
import System.Log.Logger (debugM)
import Data.Tree (Forest, Tree(..))
import Graphics.UI.Gtk.MenuComboToolbar.MenuItem
(menuItemActivate, menuItemNewWithLabel)
import IDE.Pane.Modules (addModule)
import Graphics.UI.Gtk.Windows.MessageDialog
(ButtonsType(..), MessageType(..), messageDialogNew)
import Graphics.UI.Gtk.ModelView.CellRenderer
(CellRendererMode(..), cellMode)
import IDE.Pane.PackageEditor (packageEditText)
import IDE.Utils.GtkBindings (treeViewSetActiveOnSingleClick)
import IDE.Package (packageTest, packageRun, packageClean)
import Control.Monad.Trans.Class (MonadTrans(..))
-- | The data for a single record in the Workspace Pane
data WorkspaceRecord =
FileRecord FilePath
| DirRecord FilePath
Bool -- Whether it is a source directory
| PackageRecord IDEPackage
| AddSourcesRecord
| AddSourceRecord IDEPackage
| ComponentsRecord
| ComponentRecord Text
deriving (Eq)
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 (PackageRecord p1) (PackageRecord p2) = comparing (map toLower . ipdPackageDir) p1 p2
compare (AddSourceRecord p1) (AddSourceRecord p2) = comparing (map toLower . ipdPackageDir) 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
-> IDEPackage
-> IDEM Text
toMarkup record pkg = do
mbActivePackage <- readIDE activePack
mbActiveComponent <- readIDE activeExe
return . size $ case record of
(PackageRecord p) ->
let active = Just pkg == mbActivePackage
pkgText = (if active then bold else id)
(packageIdentifierToString (ipdPackageId p))
mbLib = ipdLib p
componentText = if active
then maybe (if isJust mbLib then "(library)" else "")
(\comp -> "(" <> comp <> ")") mbActiveComponent
else ""
pkgDir = gray . T.pack $ ipdPackageDir p
in (pkgText <> " " <> componentText <> " " <> pkgDir)
(FileRecord f) -> T.pack $ takeFileName f
(DirRecord f _) | ipdPackageDir pkg == f -> "Files"
| otherwise -> T.pack $ last (splitDirectories f)
AddSourcesRecord -> "Source Dependencies"
(AddSourceRecord p) -> do
let pkgText = packageIdentifierToString (ipdPackageId p)
dirText = gray (T.pack (ipdPackageDir p))
pkgText <> " " <> dirText
ComponentsRecord -> "Components"
(ComponentRecord comp) -> do
let active = Just pkg == mbActivePackage &&
(mbActiveComponent == Nothing && comp == "library"
||
Just comp == mbActiveComponent)
(if active then bold else id) comp
where
bold str = "<b>" <> str <> "</b>"
italic str = "<i>" <> str <> "</i>"
gray str = "<span foreground=\"#999999\">" <> str <> "</span>"
size str = "<span font=\"9\">" <> str <> "</span>"
-- | The icon to show for a record
toIcon :: WorkspaceRecord -> Maybe Text
toIcon record = case record of
FileRecord path
| takeExtension path == ".hs" -> Just "ide_source"
| takeExtension path == ".cabal" -> Just "ide_cabal_file"
DirRecord p isSrc
| isSrc -> Just "ide_source_folder"
| otherwise -> Just "ide_folder"
PackageRecord _ -> Just "ide_package"
ComponentsRecord -> Just "ide_component"
AddSourcesRecord -> Just "ide_source_dependency"
AddSourceRecord _ -> Just "ide_package"
_ -> Nothing
-- | Gets the package to which a node in the tree belongs
iterToPackage :: TreeStore WorkspaceRecord -> TreeIter -> IDEM (Maybe IDEPackage)
iterToPackage store iter = do
path <- liftIO $ treeModelGetPath store iter
treePathToPackage store path
-- | Gets the package to which a node in the tree belongs
treePathToPackage :: TreeStore WorkspaceRecord -> TreePath -> IDEM (Maybe IDEPackage)
treePathToPackage store (n:_) = do
record <- liftIO $ treeStoreGetValue store [n]
case record of
(PackageRecord pkg) -> return (Just pkg)
_ -> do
liftIO $ debugM "leksah" "treePathToPackage: Unexpected entry at root forest"
return Nothing
treePathToPackage _ _ = do
liftIO $ debugM "leksah" "treePathToPackage is called with empty path"
return Nothing
-- | Determines whether the 'WorkspaceRecord' can expand, i.e. whether
-- it should get an expander.
canExpand :: WorkspaceRecord -> IDEPackage -> IDEM Bool
canExpand record pkg = case record of
(PackageRecord _) -> return True
(DirRecord fp _) -> do
mbWs <- readIDE workspace
case mbWs of
Just ws -> not . null <$> (flip runWorkspace ws . flip runPackage pkg $ dirRecords fp)
Nothing -> return False
ComponentsRecord -> return . not . null $ components
AddSourcesRecord -> return . not . null $ ipdSandboxSources pkg
(AddSourceRecord _) -> return True
_ -> return False
where components = maybeToList (ipdLib pkg) ++ ipdExes pkg ++ ipdTests pkg ++ ipdBenchmarks pkg
-- * The Workspace pane
-- | The representation of the Workspace pane
data WorkspacePane = WorkspacePane {
scrolledView :: ScrolledWindow
, treeView :: TreeView
, recordStore :: TreeStore 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 = castToWidget . scrolledView
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 = reifyIDE $ \ ideR -> do
recordStore <- treeStoreNew []
treeView <- treeViewNew
treeViewSetModel treeView recordStore
col1 <- treeViewColumnNew
treeViewColumnSetSizing col1 TreeViewColumnAutosize
treeViewColumnSetResizable col1 True
treeViewColumnSetReorderable col1 True
treeViewAppendColumn treeView col1
prefs <- reflectIDE (readIDE prefs) ideR
when (showWorkspaceIcons prefs) $ do
renderer2 <- cellRendererPixbufNew
cellLayoutPackStart col1 renderer2 False
set renderer2 [ newAttrFromMaybeStringProperty "stock-id" := (Nothing :: Maybe Text) ]
cellLayoutSetAttributes col1 renderer2 recordStore
$ \record -> [ newAttrFromMaybeStringProperty "stock-id" := toIcon record]
renderer1 <- cellRendererTextNew
cellLayoutPackStart col1 renderer1 True
cellLayoutSetAttributeFunc col1 renderer1 recordStore $ \iter -> do
record <- treeModelGetRow recordStore iter
mbPkg <- flip reflectIDE ideR $ iterToPackage recordStore iter
forM_ mbPkg $ \pkg -> do
-- The cellrenderer is stateful, so it knows which cell this markup will be for (the cell at iter)
markup <- flip reflectIDE ideR $ toMarkup record pkg
forM_ mbPkg $ \pkg -> set renderer1 [ cellTextMarkup := Just markup]
-- treeViewSetActiveOnSingleClick treeView True
treeViewSetHeadersVisible treeView False
sel <- treeViewGetSelection treeView
-- treeSelectionSetMode sel SelectionSingle
scrolledView <- scrolledWindowNew Nothing Nothing
scrolledWindowSetShadowType scrolledView ShadowIn
containerAdd scrolledView treeView
scrolledWindowSetPolicy scrolledView PolicyAutomatic PolicyAutomatic
let wsPane = WorkspacePane {..}
cid1 <- after treeView focusInEvent $ do
liftIO $ reflectIDE (makeActive wsPane) ideR
return True
on treeView rowExpanded $ \iter path -> do
record <- treeStoreGetValue recordStore path
mbPkg <- flip reflectIDE ideR $ iterToPackage recordStore iter
forM_ mbPkg $ \pkg -> do
flip reflectIDE ideR $ do
workspaceTryQuiet $ do
runPackage (refreshPackageTreeFrom recordStore treeView path) pkg
on treeView rowActivated $ \path col -> do
record <- treeStoreGetValue recordStore path
mbPkg <- flip reflectIDE ideR $ treePathToPackage recordStore path
forM_ mbPkg $ \pkg -> do
expandable <- flip reflectIDE ideR $ canExpand record pkg
case record of
FileRecord f -> void . flip reflectIDE ideR $
goToSourceDefinition' f (Location "" 1 0 1 0)
ComponentRecord name -> flip reflectIDE ideR $ workspaceTryQuiet $
workspaceActivatePackage pkg (Just name)
_ -> when expandable $ do
void $ treeViewToggleRow treeView path
(cid3, cid4) <- reflectIDE (treeViewContextMenu' treeView recordStore contextMenuItems) ideR
reflectIDE (refresh wsPane) ideR
return (Just wsPane, map ConnectC [cid1, cid3, cid4])
-- | 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
-- | Needed when building the pane, since getWorkspacePane does not
-- work before the building is finished
refresh :: WorkspacePane -> IDEAction
refresh pane = do
let store = recordStore pane
let view = treeView pane
workspaceTryQuiet $ do
packages <- sort . wsPackages <$> ask
setChildren Nothing store view [] (map PackageRecord packages)
-- | Mutates the 'TreeStore' with the given TreePath as root to attach new
-- entries to. Walks the directory tree recursively when refreshing directories.
refreshPackageTreeFrom :: TreeStore WorkspaceRecord -> TreeView -> TreePath -> PackageAction
refreshPackageTreeFrom store view path = do
record <- liftIO $ treeStoreGetValue store path
Just pkg <- liftIDE $ treePathToPackage store path
expandable <- liftIDE $ canExpand record pkg
kids <- children record
lift $ setChildren (Just pkg) store view path kids
-- | Returns the children of the 'WorkspaceRecord'.
children :: WorkspaceRecord -> PackageM [WorkspaceRecord]
children record = case record of
DirRecord dir _ -> dirRecords dir
ComponentsRecord -> componentsRecords
AddSourcesRecord -> addSourcesRecords
AddSourceRecord pkg -> return []
PackageRecord pkg -> do
p <- ask
return [ ComponentsRecord
, AddSourcesRecord
, DirRecord (ipdPackageDir p) False]
_ -> return []
-- | Gets the direct children, the add source dependencies
addSourcesRecords :: PackageM [WorkspaceRecord]
addSourcesRecords = do
pkg <- ask
return $ sort $ map AddSourceRecord (ipdSandboxSources pkg)
-- | 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 -> do
-- 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 activeExe
return $ sort $ map (\comp -> ComponentRecord comp) (components package)
where
components package = maybeToList (ipdLib package)
++ ipdExes package
++ ipdTests package
++ 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 chldren is added.
setChildren :: Maybe IDEPackage -> TreeStore WorkspaceRecord -> TreeView -> TreePath -> [WorkspaceRecord] -> WorkspaceAction
setChildren _ store _ [] [] = liftIO $ treeStoreClear store
setChildren mbPkg store view parentPath kids = do
-- We only need to get all the children right when they are visible
expanded <- if null parentPath
then return True
else liftIO $ treeViewRowExpanded view parentPath
let kidsToAdd = (if expanded
then id
else take 1) kids
forM_ (zip [0..] kidsToAdd) $ \(n, record) -> do
liftIO $ do
mbParentIter <- treeModelGetIter store parentPath
mbChildIter <- treeModelIterNthChild store mbParentIter n
let compare rec1 rec2 = case (rec1, rec2) of
(PackageRecord p1, PackageRecord p2) -> ipdCabalFile p1 == ipdCabalFile p2
_ -> rec1 == rec2
findResult <- searchToRight compare record store mbChildIter
case (mbChildIter, findResult) of
(_, WhereExpected iter) -> do -- it's already there
path <- treeModelGetPath store iter
treeStoreSetValue store path record
(Just iter, Found _) -> do -- it's already there at a later sibling
path <- treeModelGetPath store iter
removeUntil record store path
_ -> do
treeStoreInsert store parentPath n record
let pkg = case record of
PackageRecord p -> p
_ -> fromJust mbPkg
-- Only update the grand kids if they are visible
when expanded $ do
grandKids <- (`runPackage` pkg) $ children record
setChildren (Just pkg) store view (parentPath ++ [n]) grandKids
liftIO $ if null kids
then treeStoreRemoveChildren store parentPath
else when expanded . void $ removeRemaining store (parentPath++[length kids])
-- * Context menu
contextMenuItems :: WorkspaceRecord -> TreePath -> TreeStore WorkspaceRecord -> IDEM [[(Text, IDEAction)]]
contextMenuItems record path store = do
case record of
(FileRecord fp) -> do
let onDeleteFile = flip catchIDE (\(e :: SomeException) -> print e) $ reifyIDE $ \ideRef -> do
showDialogOptions
("Are you sure you want to delete " <> T.pack (takeFileName fp) <> "?")
MessageQuestion
[ ("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) $ do
mbPkg <- treePathToPackage store path
forM_ mbPkg $ \pkg -> do
mbWs <- readIDE workspace
forM_ mbWs $ \ws -> do
mbModulePath <- flip runWorkspace ws $ runPackage (dirToModulePath fp) pkg
let modulePrefix = fromMaybe [] mbModulePath
packageTry $ addModule modulePrefix
refreshWorkspacePane
let onNewTextFile = flip catchIDE (\(e :: SomeException) -> print e) $ reifyIDE $ \ideRef -> do
mbText <- showInputDialog "File name:" ""
case mbText of
Just t -> do
let path = fp </> T.unpack t
exists <- doesFileExist path
if exists
then showErrorDialog "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 "Directory name:" ""
case mbText of
Just t -> do
let path = fp </> T.unpack t
exists <- doesDirectoryExist path
if exists
then showErrorDialog "Directory already exists"
else do
createDirectory path
void $ reflectIDE refreshWorkspacePane ideRef
Nothing -> return ()
let onDeleteDir = flip catchIDE (\(e :: SomeException) -> print e) $ reifyIDE $ \ideRef -> do
showDialogOptions
("Are you sure you want to delete " <> T.pack (takeFileName fp) <> "?")
MessageQuestion
[ ("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)
]
]
PackageRecord p -> do
let onSetActive = workspaceTryQuiet $ workspaceActivatePackage p Nothing
onAddModule = workspaceTryQuiet $ runPackage (addModule []) p
onOpenCabalFile = workspaceTryQuiet $ runPackage packageEditText p
onRemoveFromWs = workspaceTryQuiet $ do
workspaceRemovePackage p
liftIDE refreshWorkspacePane
return [ [ ("New Module...", onAddModule)
, ("Set As Active Package", onSetActive)
]
, [ ("Build", workspaceTryQuiet $ runPackage makePackage p)
, ("Run", workspaceTryQuiet $ runPackage packageRun p)
, ("Test", workspaceTryQuiet $ runPackage packageTest p)
, ("Clean", workspaceTryQuiet $ runPackage packageClean p)
, ("Open Package File", onOpenCabalFile)
]
, [
("Remove From Workspace", onRemoveFromWs)
]
]
ComponentRecord comp -> do
Just pkg <- treePathToPackage store path
let onSetActive = workspaceTryQuiet $
workspaceActivatePackage pkg (Just comp)
return [[ ("Activate component", onSetActive) ]]
AddSourcesRecord -> do
Just pkg <- treePathToPackage store path
let onAddSource snapshot = workspaceTryQuiet $ flip runPackage pkg (sandboxAddSource snapshot)
return [ [ ("Add Source Dependency...", onAddSource False >> refreshWorkspacePane)
, ("Add Source Dependency Snapshot...", onAddSource True >> refreshWorkspacePane)
]
]
AddSourceRecord p -> do
Just pkg <- treePathToPackage store path
let onRemoveSourceDependency = do
workspaceTryQuiet $ flip runPackage pkg (sandboxDeleteSource (ipdPackageDir p))
onAddSourceDependencyToWs = workspaceTryQuiet . void $
workspaceAddPackage' (ipdCabalFile p)
return [ [ ("Add Package To Workspace", onAddSourceDependencyToWs >> refreshWorkspacePane)
]
, [ ("Delete Source Dependency", onRemoveSourceDependency >> refreshWorkspacePane)
]
]
_ -> 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 'TreeStore'
leaf :: a -> Tree a
leaf x = Node x []
treeStoreRemoveChildren :: TreeStore a -> TreePath -> IO ()
treeStoreRemoveChildren store path = do
Node record children <- treeStoreGetTree store path
forM_ (zip [0..] children) $ \_ -> do
treeStoreRemove store (path ++ [0]) -- this works because mutation ...
data FindResult = WhereExpected TreeIter | Found TreeIter | NotFound
-- | Tries to find the given value in the 'TreeStore'. 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 -> TreeStore a -> Maybe TreeIter -> IO FindResult
searchToRight compare _ _ Nothing = return NotFound
searchToRight compare a store (Just iter) = do
row <- treeModelGetRow store iter
if compare row a
then return $ WhereExpected iter
else treeModelIterNext store iter >>= find'
where
find' :: Maybe TreeIter -> IO FindResult
find' Nothing = return NotFound
find' (Just iter) = do
row <- treeModelGetRow store iter
if compare row a
then return $ Found iter
else treeModelIterNext store iter >>= find'
-- | 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 -> TreeStore a -> TreePath -> IO ()
removeUntil a store path = do
row <- treeStoreGetValue store path
when (row /= a) $ do
found <- treeStoreRemove store path
when found $ removeUntil a store path
-- | Starting at the node at the given 'TreePath', removes all sibling nodes to the right
removeRemaining :: TreeStore a -> TreePath -> IO ()
removeRemaining store path = do
found <- treeStoreRemove store path
when found $ removeRemaining store path