{-# LANGUAGE CPP #-} {-# LANGUAGE DeriveDataTypeable #-} {-# LANGUAGE MultiParamTypeClasses #-} {-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE TypeSynonymInstances #-} {-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE LambdaCase #-} ----------------------------------------------------------------------------- -- -- Module : IDE.Pane.Modules -- Copyright : (c) Juergen Nicklisch-Franken, Hamish Mackenzie -- License : GNU-GPL -- -- Maintainer : Juergen Nicklisch-Franken -- Stability : provisional -- Portability : portable -- -- | The pane of ide where modules are presented in tree form with their -- packages and exports -- ------------------------------------------------------------------------------- module IDE.Pane.Modules ( IDEModules(..) , ModulesState(..) , ExpanderState(..) , showModules , selectIdentifier , reloadKeepSelection , replaySelHistory , replayScopeHistory , addModule ) where import Prelude () import Prelude.Compat import Data.Maybe import qualified Data.Map as Map import Data.Map (Map) import qualified Data.Set as Set import Data.Set (Set) import Data.Tree import Data.List (find, elemIndex, foldl', nub, partition, sort) import Distribution.Package import Distribution.Version import Data.Char (toLower) import Data.IORef import IDE.Core.State import IDE.Pane.Info import IDE.Pane.SourceBuffer import Distribution.ModuleName import Distribution.Text (simpleParse,display) import Data.Typeable (Typeable(..)) import Control.Exception (SomeException(..),catch) import IDE.Package (packageConfig,addModuleToPackageDescr,delModuleFromPackageDescr,getEmptyModuleTemplate,getPackageDescriptionAndPath, ModuleLocation(..)) import Distribution.PackageDescription (PackageDescription, BuildInfo, hsSourceDirs, hasLibs, executables, testSuites, exeName, testName, benchmarks, benchmarkName, libBuildInfo, library, buildInfo, testBuildInfo, benchmarkBuildInfo) import System.FilePath (takeBaseName, (),dropFileName,makeRelative,takeDirectory) import System.Directory (doesFileExist,createDirectoryIfMissing, removeFile) import Graphics.UI.Editor.MakeEditor (buildEditor,FieldDescription(..),mkField) import Graphics.UI.Editor.Parameters (dialogRun', dialogSetDefaultResponse', dialogAddButton', Packing(..), boxPackEnd', boxPackStart', paraMinSize, paraMultiSel, Parameter(..), emptyParams, (<<<-), paraName, dialogResponse') import Graphics.UI.Editor.Simple (textEditor, boolEditor, staticListEditor) import Graphics.UI.Editor.Composite (maybeEditor) import IDE.Utils.GUIUtils (stockIdFromType, __, treeViewContextMenu, treeViewToggleRow) import IDE.Metainfo.Provider (getSystemInfo, getWorkspaceInfo, getPackageInfo) import System.Log.Logger (debugM) import Default (Default(..)) import IDE.Workspaces (packageTry) import Control.Monad.IO.Class (MonadIO(..)) import Control.Monad (when, void) import Control.Monad.Trans.Class (MonadTrans(..)) import Control.Monad.Trans.Reader (ask) import Data.Text (Text, toCaseFold) import qualified Data.Text as T (unpack, isInfixOf, toLower, pack) import Data.Monoid ((<>)) import qualified Text.Printf as S (printf) import Text.Printf (PrintfType) import qualified Data.Text.IO as T (writeFile) import GI.Gtk.Objects.Paned (panedNew, Paned(..)) import Data.GI.Gtk.ModelView.ForestStore (forestStoreInsertTree, forestStoreGetTree, forestStoreGetValue, ForestStore(..)) import GI.Gtk.Objects.RadioButton (radioButtonNewWithLabelFromWidget, radioButtonNewWithLabel, RadioButton(..)) import GI.Gtk.Objects.CheckButton (checkButtonNewWithLabel, CheckButton(..)) import GI.Gtk.Structs.TreePath (TreePath(..)) import GI.Gtk.Objects.Widget (widgetShowAll, widgetGrabDefault, setWidgetCanDefault, widgetShow, widgetSetName, widgetDestroy, widgetSetSensitive, afterWidgetFocusInEvent, widgetGetAllocation, toWidget) import GI.Gtk.Objects.Paned (panedAdd2, panedAdd1, panedSetPosition, panedGetPosition) import GI.Gtk.Objects.CellRendererPixbuf (setCellRendererPixbufStockId, cellRendererPixbufNew) import Data.GI.Base (unsafeCastTo, on, set, new') import GI.Gtk.Objects.CellRendererText (setCellRendererTextText, cellRendererTextNew) import GI.Gtk.Objects.TreeViewColumn (TreeViewColumn(..), treeViewColumnSetSortColumnId, treeViewColumnSetReorderable, treeViewColumnSetResizable, treeViewColumnSetSizing, treeViewColumnSetTitle, treeViewColumnNew) import GI.Gtk.Enums (ButtonsType(..), MessageType(..), WindowPosition(..), ResponseType(..), ButtonBoxStyle(..), PolicyType(..), ShadowType(..), SortType(..), TreeViewColumnSizing(..), Orientation(..)) import GI.Gtk.Interfaces.CellLayout (cellLayoutPackStart) import Data.GI.Gtk.ModelView.CellLayout (cellLayoutSetDataFunction) import GI.Gtk.Interfaces.TreeModel (treeModelIterNext, treeModelIterChildren, treeModelGetIterFirst, treeModelGetPath, treeModelSortNewWithModel) import GI.Gtk.Interfaces.TreeSortable (treeSortableSetSortColumnId, treeSortableSetSortFunc) import Data.GI.Gtk.ModelView.CustomStore (customStoreGetRow) import Data.GI.Gtk.ModelView.Types (treeSelectionGetSelectedRows', treePathGetIndices', treePathNewFromIndices', TypedTreeModelSort(..)) import GI.Gtk.Objects.ScrolledWindow (scrolledWindowSetPolicy, scrolledWindowSetShadowType, scrolledWindowNew) import GI.Gtk.Objects.Adjustment (noAdjustment) import GI.Gtk.Objects.Container (containerAdd) import Graphics.UI.Frame.Rectangle (getRectangleY, getRectangleX, Rectangle(..)) import GI.Gtk.Objects.Box (boxReorderChild, Box(..), boxSetSpacing, boxNew) import GI.Gtk.Objects.ButtonBox (buttonBoxSetLayout, buttonBoxNew) import GI.Gtk.Objects.ToggleButton (toggleButtonGetActive, onToggleButtonToggled, toggleButtonSetActive) import GI.Gtk.Objects.TreeView (treeViewSetSearchColumn, treeViewCollapseRow, treeViewCollapseAll, treeViewExpandAll, treeViewExpandRow, treeViewRowExpanded, treeViewScrollToCell, treeViewGetColumn, treeViewExpandToPath, treeViewGetSelection, onTreeViewRowActivated, treeViewSetSearchEqualFunc, treeViewSetEnableSearch, treeViewSetHeadersVisible, treeViewAppendColumn, treeViewSetModel, treeViewNew, TreeView(..)) import GI.Gtk.Objects.TreeSelection (treeSelectionUnselectAll, treeSelectionSelectPath, onTreeSelectionChanged) import GI.Gtk.Objects.TreeModelSort (TreeModelSort(..), treeModelSortConvertPathToChildPath, treeModelSortConvertChildPathToPath) import GI.Gtk.Structs.TreeIter (TreeIter(..)) import GI.Gtk.Objects.Menu (Menu(..)) import GI.Gtk.Objects.MenuItem (toMenuItem, onMenuItemActivate, MenuItem(..), menuItemActivate, menuItemNewWithLabel) import GI.Gtk.Objects.SeparatorMenuItem (separatorMenuItemNew) import GI.Gtk.Objects.MenuShell (menuShellAppend) import GI.Gtk.Objects.MessageDialog (setMessageDialogText, constructMessageDialogButtons, setMessageDialogMessageType, MessageDialog(..)) import GI.Gtk.Objects.Dialog (Dialog(..), dialogResponse, dialogGetActionArea, dialogGetContentArea, constructDialogUseHeaderBar) import GI.Gtk.Objects.Window (windowSetDefaultSize, setWindowTitle, setWindowTransientFor, Window(..), setWindowWindowPosition, windowSetTransientFor) import GI.Gtk.Objects.Button (Button(..), onButtonClicked, buttonNewFromStock) import GI.Gtk.Objects.Label (labelSetText, labelSetLineWrap, labelNew) import Data.GI.Gtk.ModelView.ForestStore (forestStoreClear, forestStoreNew) import Data.Int (Int32) #if MIN_VERSION_Cabal(2,0,0) import Distribution.Types.UnqualComponentName (unUnqualComponentName) #endif #if !MIN_VERSION_Cabal(2,0,0) type UnqualComponentName = String unUnqualComponentName :: UnqualComponentName -> String unUnqualComponentName = id #endif printf :: PrintfType r => Text -> r printf = S.printf . T.unpack -- | A modules pane description -- type ModuleRecord = (Text, Maybe (ModuleDescr,PackageDescr)) data IDEModules = IDEModules { outer :: Box , paned :: Paned , treeView :: TreeView , forestStore :: ForestStore ModuleRecord , descrView :: TreeView , descrStore :: ForestStore Descr , descrSortedStore :: TypedTreeModelSort Descr -- ^ The sorted model for descrs , packageScopeB :: RadioButton , workspaceScopeB :: RadioButton , systemScopeB :: RadioButton , dependsB :: CheckButton , blacklistB :: CheckButton , oldSelection :: IORef SelectionState , expanderState :: IORef ExpanderState } deriving Typeable data ModulesState = ModulesState Int (Scope,Bool) (Maybe ModuleName, Maybe Text) ExpanderState deriving(Eq,Ord,Read,Show,Typeable) data ExpanderState = ExpanderState { packageExp :: ExpanderFacet , packageExpNoBlack :: ExpanderFacet , packageDExp :: ExpanderFacet , packageDExpNoBlack :: ExpanderFacet , workspaceExp :: ExpanderFacet , workspaceExpNoBlack :: ExpanderFacet , workspaceDExp :: ExpanderFacet , workspaceDExpNoBlack :: ExpanderFacet , systemExp :: ExpanderFacet , systemExpNoBlack :: ExpanderFacet } deriving (Eq,Ord,Show,Read) type ExpanderFacet = ([[Int]], [[Int]]) data SelectionState = SelectionState { moduleS' :: Maybe ModuleName , facetS' :: Maybe Text , scope' :: Scope , blacklist' :: Bool} deriving (Eq,Ord,Show) instance Pane IDEModules IDEM where primPaneName _ = __ "Modules" getAddedIndex _ = 0 getTopWidget = liftIO . toWidget . outer paneId b = "*Modules" --liftIO $ widgetGrabFocus (descrView p) getModules :: Maybe PanePath -> IDEM IDEModules getModules Nothing = forceGetPane (Right "*Modules") getModules (Just pp) = forceGetPane (Left pp) showModules :: IDEAction showModules = do pane <- getModules Nothing displayPane pane False orderToInt32 :: Ordering -> Int32 orderToInt32 LT = -1 orderToInt32 EQ = 0 orderToInt32 GT = 1 instance RecoverablePane IDEModules ModulesState IDEM where saveState p = do m <- getModules Nothing sc <- getScope mbModules <- getPane recordExpanderState expander <- liftIO $ readIORef (expanderState p) case mbModules of Nothing -> return Nothing Just p -> do i <- panedGetPosition (paned p) mbTreeSelection <- getSelectionTree (treeView m) (forestStore m) mbFacetSelection <- getSelectionDescr (descrView m) (descrStore m) (descrSortedStore m) let mbs = (case mbTreeSelection of Just (_,Just (md,_)) -> Just (modu $ mdModuleId md) _ -> Nothing, case mbFacetSelection of Nothing -> Nothing Just fw -> Just (dscName fw)) return (Just (ModulesState (fromIntegral i) sc mbs expander)) recoverState pp (ModulesState i sc@(scope,useBlacklist) se exp) = do nb <- getNotebook pp p <- buildPane pp nb builder mod <- getModules Nothing liftIO $ writeIORef (expanderState mod) exp liftIO $ writeIORef (oldSelection mod) (uncurry SelectionState se scope useBlacklist) panedSetPosition (paned mod) (fromIntegral i) return p builder pp nb windows = do packageInfo' <- getPackageInfo ideR <- ask let forest = case packageInfo' of Nothing -> [] Just (GenScopeC fst, GenScopeC snd) -> subForest (buildModulesTree (fst,snd)) forestStore <- forestStoreNew forest treeView <- treeViewNew treeViewSetModel treeView (Just forestStore) --treeViewSetRulesHint treeView True renderer0 <- cellRendererPixbufNew setCellRendererPixbufStockId renderer0 "" renderer <- cellRendererTextNew col <- treeViewColumnNew treeViewColumnSetTitle col (__ "Module") treeViewColumnSetSizing col TreeViewColumnSizingAutosize treeViewColumnSetResizable col True treeViewColumnSetReorderable col True treeViewAppendColumn treeView col cellLayoutPackStart col renderer0 False cellLayoutPackStart col renderer True cellLayoutSetDataFunction col renderer forestStore $ setCellRendererTextText renderer . fst cellLayoutSetDataFunction col renderer0 forestStore $ \row -> setCellRendererPixbufStockId renderer0 $ case snd row of Nothing -> "" Just pair -> if isJust (mdMbSourcePath (fst pair)) then "ide_source" else "" renderer2 <- cellRendererTextNew col2 <- treeViewColumnNew treeViewColumnSetTitle col2 (__ "Package") treeViewColumnSetSizing col2 TreeViewColumnSizingAutosize treeViewColumnSetResizable col2 True treeViewColumnSetReorderable col2 True treeViewAppendColumn treeView col2 cellLayoutPackStart col2 renderer2 True cellLayoutSetDataFunction col2 renderer2 forestStore $ \row -> setCellRendererTextText renderer2 $ case snd row of Nothing -> "" Just pair -> (T.pack . display . pdPackage . snd) pair treeViewSetHeadersVisible treeView True treeViewSetEnableSearch treeView True treeViewSetSearchEqualFunc treeView (\_ _ key iter -> treeViewSearch treeView forestStore key iter) treeViewSetSearchColumn treeView 0 -- Facet view descrView <- treeViewNew descrStore <- forestStoreNew [] -- sorted model descrSortedStore <- treeModelSortNewWithModel descrStore >>= liftIO . unsafeCastTo TypedTreeModelSort treeViewSetModel descrView (Just descrSortedStore) renderer30 <- cellRendererPixbufNew renderer31 <- cellRendererPixbufNew renderer3 <- cellRendererTextNew col <- treeViewColumnNew treeViewColumnSetTitle col (__ "Interface") --treeViewColumnSetSizing col TreeViewColumnSizingAutosize treeViewAppendColumn descrView col cellLayoutPackStart col renderer30 False cellLayoutPackStart col renderer31 False cellLayoutPackStart col renderer3 True cellLayoutSetDataFunction col renderer3 descrStore $ setCellRendererTextText renderer3 . descrTreeText cellLayoutSetDataFunction col renderer30 descrStore $ setCellRendererPixbufStockId renderer30 . stockIdFromType . descrIdType cellLayoutSetDataFunction col renderer31 descrStore $ \row -> setCellRendererPixbufStockId renderer31 $ if isReexported row then "ide_reexported" else if isJust (dscMbLocation row) then if dscExported row then "ide_source" else "ide_source_local" else "ide_empty" -- sort definitions on name, ignoring case treeSortableSetSortFunc descrSortedStore 2 $ \_ iter1 iter2 -> do d1 <- customStoreGetRow descrStore iter1 d2 <- customStoreGetRow descrStore iter2 let cafName = toCaseFold . descrTreeText return . orderToInt32 $ compare (cafName d1) (cafName d2) treeViewColumnSetSortColumnId col 2 treeSortableSetSortColumnId descrSortedStore 2 SortTypeAscending treeViewSetHeadersVisible descrView True treeViewSetEnableSearch descrView True treeViewSetSearchEqualFunc descrView (\_ _ key iter -> descrViewSearch descrView descrStore key iter) pane' <- panedNew OrientationHorizontal sw <- scrolledWindowNew noAdjustment noAdjustment scrolledWindowSetShadowType sw ShadowTypeIn containerAdd sw treeView scrolledWindowSetPolicy sw PolicyTypeAutomatic PolicyTypeAutomatic sw2 <- scrolledWindowNew noAdjustment noAdjustment scrolledWindowSetShadowType sw2 ShadowTypeIn containerAdd sw2 descrView scrolledWindowSetPolicy sw2 PolicyTypeAutomatic PolicyTypeAutomatic panedAdd1 pane' sw panedAdd2 pane' sw2 rect <- widgetGetAllocation nb x <- getRectangleX rect y <- getRectangleY rect panedSetPosition pane' (max 200 (x `quot` 2)) box <- buttonBoxNew OrientationHorizontal boxSetSpacing box 2 buttonBoxSetLayout box ButtonBoxStyleSpread rb1 <- radioButtonNewWithLabel ([]::[RadioButton]) (__ "Package") rb2 <- radioButtonNewWithLabelFromWidget (Just rb1) (__ "Workspace") rb3 <- radioButtonNewWithLabelFromWidget (Just rb1) (__ "System") toggleButtonSetActive rb3 True cb2 <- checkButtonNewWithLabel (__ "Imports") cb <- checkButtonNewWithLabel (__ "Blacklist") boxPackStart' box rb1 PackGrow 0 boxPackStart' box rb2 PackGrow 0 boxPackStart' box rb3 PackGrow 0 boxPackEnd' box cb PackNatural 0 boxPackEnd' box cb2 PackNatural 0 boxOuter <- boxNew OrientationVertical 0 boxPackStart' boxOuter box PackNatural 2 boxPackStart' boxOuter pane' PackGrow 0 oldState <- liftIO $ newIORef $ SelectionState Nothing Nothing SystemScope False expanderState <- liftIO $ newIORef emptyExpansion scopeRef <- liftIO $ newIORef (SystemScope,True) let modules = IDEModules boxOuter pane' treeView forestStore descrView descrStore descrSortedStore rb1 rb2 rb3 cb2 cb oldState expanderState cid1 <- onIDE afterWidgetFocusInEvent treeView $ do liftIDE $ makeActive modules return True cid2 <- onIDE afterWidgetFocusInEvent descrView $ do liftIDE $ makeActive modules return True cids3 <- treeViewContextMenu treeView $ modulesContextMenu ideR forestStore treeView cid5 <- ConnectC treeView <$> onTreeViewRowActivated treeView (modulesSelect ideR forestStore treeView) cids6 <- treeViewContextMenu descrView $ descrViewContextMenu ideR descrStore descrSortedStore descrView cid8 <- ConnectC descrView <$> onTreeViewRowActivated descrView (descrViewSelect ideR descrStore descrSortedStore) onToggleButtonToggled rb1 (reflectIDE scopeSelection ideR) onToggleButtonToggled rb2 (reflectIDE scopeSelection ideR) onToggleButtonToggled rb3 (reflectIDE scopeSelection ideR) onToggleButtonToggled cb (reflectIDE scopeSelection ideR) onToggleButtonToggled cb2 (reflectIDE scopeSelection ideR) sel <- treeViewGetSelection treeView onTreeSelectionChanged sel $ do fillFacets treeView forestStore descrView descrStore descrSortedStore reflectIDE recordSelHistory ideR return () sel2 <- treeViewGetSelection descrView onTreeSelectionChanged sel2 $ do fillInfo descrView descrStore descrSortedStore ideR reflectIDE recordSelHistory ideR return () return (Just modules, [cid1, cid2, cid5, cid8] ++ cids3 ++ cids6) selectIdentifier :: Descr -> Bool -> IDEAction selectIdentifier idDescr openSource= do liftIO $ debugM "leksah" "selectIdentifier" systemScope <- getSystemInfo workspaceScope <- getWorkspaceInfo packageScope <- getPackageInfo currentScope <- getScope case dsMbModu idDescr of Nothing -> return () Just pm -> case scopeForDescr pm packageScope workspaceScope systemScope of Nothing -> return () Just sc -> do when (fst currentScope < sc) (setScope (sc,snd currentScope)) selectIdentifier' (modu pm) (dscName idDescr) when openSource (goToDefinition idDescr) scopeForDescr :: PackModule -> Maybe (GenScope,GenScope) -> Maybe (GenScope,GenScope) -> Maybe GenScope -> Maybe Scope scopeForDescr pm packageScope workspaceScope systemScope = case ps of (True, r) -> Just (PackageScope r) _ -> case ws of (True, r) -> Just (WorkspaceScope r) _ -> case systemScope of Nothing -> Nothing Just (GenScopeC(PackScope ssc _)) -> if Map.member pid ssc then Just SystemScope else Nothing where pid = pack pm ps = case packageScope of Nothing -> (False,False) Just (GenScopeC (PackScope psc1 _), GenScopeC (PackScope psc2 _)) | Map.member pid psc1 -> (True, False) | Map.member pid psc2 -> (True, True) | otherwise -> (False, False) ws = case workspaceScope of Nothing -> (False,False) Just (GenScopeC (PackScope wsc1 _), GenScopeC (PackScope wsc2 _)) | Map.member pid wsc1 -> (True, False) | Map.member pid wsc2 -> (True, True) | otherwise -> (False, False) selectIdentifier' :: ModuleName -> Text -> IDEAction selectIdentifier' moduleName symbol = let nameArray = map T.pack $ components moduleName in do liftIO $ debugM "leksah" $ "selectIdentifier' " <> show moduleName <> " " <> T.unpack symbol mods <- getModules Nothing mbTree <- forestStoreGetTreeSave (forestStore mods) =<< treePathNewFromIndices' [] case treePathFromNameArray mbTree nameArray [] of Just treePath' -> do treePath <- treePathNewFromIndices' (map fromIntegral treePath') treeViewExpandToPath (treeView mods) treePath sel <- treeViewGetSelection (treeView mods) treeSelectionSelectPath sel treePath Just col <- treeViewGetColumn (treeView mods) 0 treeViewScrollToCell (treeView mods) (Just treePath) (Just col) True 0.3 0.3 mbFacetTree <- forestStoreGetTreeSave (descrStore mods) =<< treePathNewFromIndices' [] selF <- treeViewGetSelection (descrView mods) case findPathFor symbol mbFacetTree of Nothing -> sysMessage Normal (__ "no path found") Just childPath -> do Just path <- treeModelSortConvertChildPathToPath (descrSortedStore mods) =<< treePathNewFromIndices' (map fromIntegral childPath) treeViewExpandToPath (descrView mods) path treeSelectionSelectPath selF path Just col <- treeViewGetColumn (descrView mods) 0 treeViewScrollToCell (descrView mods) (Just path) (Just col) True 0.3 0.3 bringPaneToFront mods Nothing -> return () findPathFor :: Text -> Maybe (Tree Descr) -> Maybe [Int] findPathFor symbol (Just (Node _ forest)) = foldr ( \i mbTreePath -> findPathFor' [i] (forest !! i) mbTreePath) Nothing [0 .. (length forest - 1)] where findPathFor' :: [Int] -> Tree Descr -> Maybe [Int] -> Maybe [Int] findPathFor' _ node (Just p) = Just p findPathFor' path (Node wrap sub) Nothing = if dscName wrap == symbol then Just (reverse path) else foldr ( \i mbTreePath -> findPathFor' (i:path) (sub !! i) mbTreePath) Nothing [0 .. (length sub - 1)] findPathFor symbol Nothing = Nothing treePathFromNameArray :: Maybe ModTree -> [Text] -> [Int] -> Maybe [Int] treePathFromNameArray (Just tree) [] accu = Just (reverse accu) treePathFromNameArray (Just tree) (h:t) accu = let names = map (fst . rootLabel) (subForest tree) mbIdx = elemIndex h names in case mbIdx of Nothing -> Nothing Just i -> treePathFromNameArray (Just (subForest tree !! i)) t (i:accu) treePathFromNameArray Nothing _ _ = Nothing treeViewSearch :: TreeView -> ForestStore ModuleRecord -> Text -> TreeIter -> IO Bool treeViewSearch treeView forestStore string iter = do liftIO $ debugM "leksah" "treeViewSearch" path <- treeModelGetPath forestStore iter val <- forestStoreGetValue forestStore path mbTree <- forestStoreGetTreeSave forestStore path exp <- treeViewRowExpanded treeView path when (isJust mbTree && not (null (subForest (fromJust mbTree))) && not exp) $ let found = searchInModSubnodes (fromJust mbTree) string in when found $ do treeViewExpandRow treeView path False return () let str2 = case snd val of Just (mod,_) -> showPackModule (mdModuleId mod) Nothing -> "" let res = T.isInfixOf (T.toLower string) (T.toLower str2) return res searchInModSubnodes :: ModTree -> Text -> Bool searchInModSubnodes tree str = any (\ (_, mbPair) -> case mbPair of Nothing -> False Just (mod, _) -> let cstr = T.pack $ show (Present (mdModuleId mod)) in T.isInfixOf (T.toLower str) (T.toLower cstr)) (concatMap flatten (subForest tree)) descrViewSearch :: TreeView -> ForestStore Descr -> Text -> TreeIter -> IO Bool descrViewSearch descrView descrStore string iter = do liftIO $ debugM "leksah" "descrViewSearch" path <- treeModelGetPath descrStore iter val <- forestStoreGetValue descrStore path tree <- forestStoreGetTree descrStore path exp <- treeViewRowExpanded descrView path when (not (null (subForest tree)) && not exp) $ let found = searchInFacetSubnodes tree string in when found $ do treeViewExpandRow descrView path False return () return (T.isInfixOf (T.toLower string) (T.toLower (descrTreeText val))) searchInFacetSubnodes :: DescrTree -> Text -> Bool searchInFacetSubnodes tree str = any (T.isInfixOf (T.toLower str) . T.toLower . descrTreeText) (concatMap flatten (subForest tree)) -- | Fill facet view with descrs from selected module fillFacets :: (Applicative m, MonadIO m) => TreeView -> ForestStore ModuleRecord -> TreeView -> ForestStore Descr -> TypedTreeModelSort Descr -> m () fillFacets treeView forestStore descrView descrStore descrSortedStore = do liftIO $ debugM "leksah" "fillFacets" sel <- getSelectionTree treeView forestStore emptyModel <- forestStoreNew [] treeViewSetModel descrView (Just emptyModel) forestStoreClear descrStore emptyPath <- treePathNewFromIndices' [] case sel of Just (_,Just (mod,package)) -> mapM_ (\(e,i) -> forestStoreInsertTree descrStore emptyPath i e) $ zip (buildFacetForrest mod) [0 ..] _ -> return () treeViewSetModel descrView (Just descrSortedStore) treeViewSetEnableSearch descrView True treeViewSetSearchEqualFunc descrView (\_ _ key iter -> descrViewSearch descrView descrStore key iter) liftIO $ debugM "leksah" "fillFacets done" getSelectionTree :: (Applicative m, MonadIO m) => TreeView -> ForestStore ModuleRecord -> m (Maybe ModuleRecord) getSelectionTree treeView forestStore = do liftIO $ debugM "leksah" "getSelectionTree" treeSelection <- treeViewGetSelection treeView paths <- treeSelectionGetSelectedRows' treeSelection case paths of [] -> return Nothing a:r -> Just <$> forestStoreGetValue forestStore a -- | Get selected Descr, if any getSelectionDescr :: (Applicative m, MonadIO m) => TreeView -> ForestStore Descr -> TypedTreeModelSort Descr -> m (Maybe Descr) getSelectionDescr treeView forestStore descrSortedStore = do liftIO $ debugM "leksah" "getSelectionDescr" treeSelection <- treeViewGetSelection treeView paths <- treeSelectionGetSelectedRows' treeSelection case paths of a:_ -> do Just unsorteda <- treeModelSortConvertPathToChildPath descrSortedStore a Just <$> forestStoreGetValue forestStore unsorteda _ -> return Nothing -- | Fill info pane with selected Descr if any fillInfo :: (Applicative m, MonadIO m) => TreeView -> ForestStore Descr -> TypedTreeModelSort Descr -> IDERef -> m () fillInfo treeView lst descrSortedStore ideR = do liftIO $ debugM "leksah" "fillInfo" treeSelection <- treeViewGetSelection treeView paths <- treeSelectionGetSelectedRows' treeSelection case paths of [] -> return () [a] -> do Just unsorteda <- treeModelSortConvertPathToChildPath descrSortedStore a descr <- forestStoreGetValue lst unsorteda liftIO $ reflectIDE (setInfo descr) ideR return () _ -> return () findDescription :: SymbolTable alpha => PackModule -> alpha -> Text -> Maybe (Text,Descr) findDescription md st s = case filter (\id -> case dsMbModu id of Nothing -> False Just pm -> md == pm) (symLookup s st) of [] -> Nothing l -> Just (s,head l) getEmptyDefaultScope :: Map Text [Descr] getEmptyDefaultScope = Map.empty fillModulesList :: (Scope,Bool) -> IDEAction fillModulesList (scope,useBlacklist) = do liftIO $ debugM "leksah" "fillModulesList" mods <- getModules Nothing prefs <- readIDE prefs case scope of SystemScope -> do accessibleInfo' <- getSystemInfo case accessibleInfo' of Nothing -> forestStoreClear (forestStore mods) --forestStoreInsertTree (forestStore mods) [] 0 (Node ("",[]) []) Just (GenScopeC ai@(PackScope pm ps)) -> let p2 = if useBlacklist then PackScope (Map.filter (filterBlacklist (packageBlacklist prefs)) pm) ps else ai (Node _ li) = buildModulesTree (PackScope Map.empty getEmptyDefaultScope,p2) in insertIt li mods WorkspaceScope withImports -> do workspaceInfo' <- getWorkspaceInfo packageInfo' <- getPackageInfo case workspaceInfo' of Nothing -> insertIt [] mods Just (GenScopeC l,GenScopeC p) -> let (l',p'@(PackScope pm ps)) = if withImports then (l, p) else (l, PackScope Map.empty symEmpty) p2 = if useBlacklist then PackScope (Map.filter (filterBlacklist (packageBlacklist prefs)) pm) ps else p' (Node _ li) = buildModulesTree (l', p2) in insertIt li mods PackageScope withImports -> do packageInfo' <- getPackageInfo case packageInfo' of Nothing -> insertIt [] mods Just (GenScopeC l,GenScopeC p) -> let (l',p'@(PackScope pm ps)) = if withImports then (l,p) else (l, PackScope Map.empty symEmpty) p2 = if useBlacklist then PackScope (Map.filter (filterBlacklist (packageBlacklist prefs)) pm) ps else p' (Node _ li) = buildModulesTree (l', p2) in insertIt li mods where insertIt li mods = do emptyModel <- forestStoreNew [] treeViewSetModel (treeView mods) (Just emptyModel) forestStoreClear (forestStore mods) emptyPath <- treePathNewFromIndices' [] mapM_ (\(e,i) -> forestStoreInsertTree (forestStore mods) emptyPath i e) $ zip li [0 .. length li] treeViewSetModel (treeView mods) (Just $ forestStore mods) treeViewSetEnableSearch (treeView mods) True treeViewSetSearchEqualFunc (treeView mods) (\_ _ key iter -> treeViewSearch (treeView mods) (forestStore mods) key iter) filterBlacklist :: [Dependency] -> PackageDescr -> Bool filterBlacklist dependencies packageDescr = let packageId = pdPackage packageDescr name = pkgName packageId version = pkgVersion packageId in isNothing $ find (\ (Dependency str vr) -> str == name && withinRange version vr) dependencies type DescrForest = Forest Descr type DescrTree = Tree Descr descrTreeText :: Descr -> Text descrTreeText (Real (RealDescr id _ _ _ _ (InstanceDescr binds) _)) = id <> " " <> printBinds binds where printBinds [] = "" printBinds [a] = a printBinds (a:b) = a <> " " <> printBinds b descrTreeText d = dscName d descrIdType :: Descr -> DescrType descrIdType = descrType . dscTypeHint buildFacetForrest :: ModuleDescr -> DescrForest buildFacetForrest modDescr = let (instances,other) = partition (\id -> case dscTypeHint id of InstanceDescr _ -> True _ -> False) $ take 2000 $ mdIdDescriptions modDescr -- TODO: Patch for toxioc TypeLevel package with 28000 aliases forestWithoutInstances = map buildFacet other (forest2,orphaned) = foldl' addInstances (forestWithoutInstances,[]) instances orphanedNodes = map (\ inst -> Node inst []) orphaned in forest2 ++ reverse orphanedNodes where -- expand nodes in a module desciption for the description tree buildFacet :: Descr -> DescrTree buildFacet descr = case dscTypeHint descr of DataDescr constructors fields -> Node descr (map (\ (SimpleDescr fn ty loc comm exp) -> Node (makeReexported descr (Real RealDescr{dscName' = fn, dscMbTypeStr' = ty, dscMbModu' = dsMbModu descr, dscMbLocation' = loc, dscMbComment' = comm, dscTypeHint' = ConstructorDescr descr, dscExported' = exp})) []) constructors ++ map (\ (SimpleDescr fn ty loc comm exp) -> Node (makeReexported descr (Real RealDescr{dscName' = fn, dscMbTypeStr' = ty, dscMbModu' = dsMbModu descr, dscMbLocation' = loc, dscMbComment' = comm, dscTypeHint' = FieldDescr descr, dscExported' = exp})) []) fields) NewtypeDescr (SimpleDescr fn ty loc comm exp) mbField -> Node descr (Node (makeReexported descr (Real RealDescr{dscName' = fn, dscMbTypeStr' = ty, dscMbModu' = dsMbModu descr, dscMbLocation' = loc, dscMbComment' = comm, dscTypeHint' = ConstructorDescr descr, dscExported' = exp})) [] : case mbField of Just (SimpleDescr fn ty loc comm exp) -> [Node (makeReexported descr (Real RealDescr{dscName' = fn, dscMbTypeStr' = ty, dscMbModu' = dsMbModu descr, dscMbLocation' = loc, dscMbComment' = comm, dscTypeHint' = FieldDescr descr, dscExported' = exp})) []] Nothing -> []) ClassDescr _ methods -> Node descr (map (\(SimpleDescr fn ty loc comm exp) -> Node (makeReexported descr (Real RealDescr{dscName' = fn, dscMbTypeStr' = ty, dscMbModu' = dsMbModu descr, dscMbLocation' = loc, dscMbComment' = comm, dscTypeHint' = MethodDescr descr, dscExported' = exp})) []) methods) _ -> Node descr [] where makeReexported :: Descr -> Descr -> Descr makeReexported (Reexported d1) d2 = Reexported ReexportedDescr{dsrMbModu = dsrMbModu d1, dsrDescr = d2} makeReexported _ d2 = d2 addInstances :: (DescrForest,[Descr]) -> Descr -> (DescrForest,[Descr]) addInstances (forest,orphaned) instDescr = case foldr (matches instDescr) ([],False) forest of (f,True) -> (f,orphaned) (f,False) -> (forest, instDescr:orphaned) matches :: Descr -> DescrTree -> (DescrForest,Bool) -> (DescrForest,Bool) matches (Real (instDescr@RealDescr{dscTypeHint' = InstanceDescr binds})) (Node dd@(Real (RealDescr id _ _ _ _ (DataDescr _ _) _)) sub) (forest,False) | not (null binds) && id == head binds = (Node dd (sub ++ [Node newInstDescr []]) : forest,True) where newInstDescr = if isNothing (dscMbLocation' instDescr) then Real $ instDescr{dscMbLocation' = dscMbLocation dd} else Real instDescr matches (Real (instDescr@RealDescr{dscTypeHint' = InstanceDescr binds})) (Node dd@(Real (RealDescr id _ _ _ _ (NewtypeDescr _ _) _)) sub) (forest,False) | not (null binds) && id == head binds = (Node dd (sub ++ [Node newInstDescr []]) : forest,True) where newInstDescr = if isNothing (dscMbLocation' instDescr) then Real $ instDescr{dscMbLocation' = dscMbLocation dd} else Real instDescr matches _ node (forest,b) = (node:forest,b) defaultRoot :: Tree ModuleRecord defaultRoot = Node ("",Just (getDefault,getDefault)) [] type ModTree = Tree ModuleRecord -- -- | Make a Tree with a module desription, package description pairs tree to display. -- Their are nodes with a label but without a module (like e.g. Data). -- buildModulesTree :: (SymbolTable alpha, SymbolTable beta) => (PackScope alpha,PackScope beta ) -> ModTree buildModulesTree (PackScope localMap _,PackScope otherMap _) = let modDescrPackDescr = concatMap (\p -> map (\m -> (m,p)) (pdModules p)) (Map.elems localMap ++ Map.elems otherMap) resultTree = foldl' insertPairsInTree defaultRoot modDescrPackDescr in sortTree resultTree -- | Insert module and package info into the tre insertPairsInTree :: ModTree -> (ModuleDescr,PackageDescr) -> ModTree insertPairsInTree tree pair = let nameArray = modTreeName $ fst pair (startArray,last) = splitAt (length nameArray - 1) nameArray pairedWith = map (\ n -> (n, Nothing)) startArray ++ [(head last, Just pair)] in insertNodesInTree pairedWith tree where modTreeName modDescr = let modId = mdModuleId modDescr modName = modu modId mFilePath = mdMbSourcePath modDescr -- show relative file path for Main modules -- since we can have several in case (components modName,mFilePath) of (["Main"],Just fp) -> let sfp = case (pdMbSourcePath (snd pair)) of Nothing -> fp Just pfp -> makeRelative (takeDirectory pfp) fp in [T.pack $ "Main ("++sfp++")"] (cmps,_) -> map T.pack cmps insertNodesInTree :: [ModuleRecord] -> ModTree -> ModTree insertNodesInTree [p1@(str1,Just pair)] (Node p2@(str2,mbPair) forest2) = case partition (\ (Node (s,_) _) -> s == str1) forest2 of ([found],rest) -> case found of Node p3@(_,Nothing) forest3 -> Node p2 (Node p1 forest3 : rest) Node p3@(_,Just pair3) forest3 -> Node p2 (Node p1 [] : Node p3 forest3 : rest) ([],rest) -> Node p2 (Node p1 [] : forest2) (found,rest) -> case head found of Node p3@(_,Nothing) forest3 -> Node p2 (Node p1 forest3 : tail found ++ rest) Node p3@(_,Just pair3) forest3 -> Node p2 (Node p1 [] : Node p3 forest3 : tail found ++ rest) insertNodesInTree li@(hd@(str1,Nothing):tl) (Node p@(str2,mbPair) forest) = case partition (\ (Node (s,_) _) -> s == str1) forest of ([found],rest) -> Node p (insertNodesInTree tl found : rest) ([],rest) -> Node p (makeNodes li : forest) (found,rest) -> Node p (insertNodesInTree tl (head found) : tail found ++ rest) insertNodesInTree [] n = n insertNodesInTree _ _ = error (T.unpack $ __ "Modules>>insertNodesInTree: Should not happen2") makeNodes :: [(Text,Maybe (ModuleDescr,PackageDescr))] -> ModTree makeNodes [(str,mbPair)] = Node (str,mbPair) [] makeNodes ((str,mbPair):tl) = Node (str,mbPair) [makeNodes tl] makeNodes _ = throwIDE (__ "Impossible in makeNodes") instance Ord a => Ord (Tree a) where compare (Node l1 _) (Node l2 _) = compare l1 l2 sortTree :: Ord a => Tree a -> Tree a sortTree (Node l forest) = Node l (sort (map sortTree forest)) getSelectedModuleFile :: Maybe ModuleRecord -> Maybe FilePath getSelectedModuleFile sel = case sel of Just (_,Just (m,p)) -> case (mdMbSourcePath m, pdMbSourcePath p) of (Just fp, Just pp) -> Just $ dropFileName pp fp (Just fp, Nothing) -> Just fp _ -> Nothing _ -> Nothing modulesContextMenu :: IDERef -> ForestStore ModuleRecord -> TreeView -> Menu -> IO () modulesContextMenu ideR store treeView theMenu = do liftIO $ debugM "leksah" "modulesContextMenu" item1 <- menuItemNewWithLabel (__ "Edit source") onMenuItemActivate item1 $ do mbFile <- getSelectedModuleFile <$> getSelectionTree treeView store case mbFile of Nothing -> return () Just fp -> void $ reflectIDE (selectSourceBuf fp) ideR sep1 <- separatorMenuItemNew >>= liftIO . toMenuItem item2 <- menuItemNewWithLabel (__ "Expand here") onMenuItemActivate item2 $ expandHere treeView item3 <- menuItemNewWithLabel (__ "Collapse here") onMenuItemActivate item3 $ collapseHere treeView item4 <- menuItemNewWithLabel (__ "Expand all") onMenuItemActivate item4 $ treeViewExpandAll treeView item5 <- menuItemNewWithLabel (__ "Collapse all") onMenuItemActivate item5 $ treeViewCollapseAll treeView sep2 <- separatorMenuItemNew >>= liftIO . toMenuItem item6 <- menuItemNewWithLabel (__ "Add module") onMenuItemActivate item6 $ reflectIDE (packageTry $ addModule' treeView store) ideR item7 <- menuItemNewWithLabel (__ "Delete module") onMenuItemActivate item7 $ do mbFile <- getSelectedModuleFile <$> getSelectionTree treeView store case mbFile of Nothing -> return () Just fp -> do resp <- reflectIDE respDelModDialog ideR when resp $ do exists <- doesFileExist fp if exists then do reflectIDE (liftIO $ removeFile fp) ideR reflectIDE (packageTry $ delModule treeView store)ideR else reflectIDE (packageTry $ delModule treeView store)ideR reflectIDE (packageTry packageConfig) ideR return () sel <- getSelectionTree treeView store case sel of Just (s, Nothing) -> mapM_ (menuShellAppend theMenu) [item1, sep1, item2, item3, item4, item5, sep2, item6] Just (_,Just (m,_)) -> mapM_ (menuShellAppend theMenu) [item1, sep1, item2, item3, item4, item5, sep2, item6, item7] _ -> return () modulesSelect :: IDERef -> ForestStore ModuleRecord -> TreeView -> TreePath -> TreeViewColumn -> IO () modulesSelect ideR store treeView path _ = do liftIO $ debugM "leksah" "modulesSelect" treeViewToggleRow treeView path mbFile <- getSelectedModuleFile <$> getSelectionTree treeView store case mbFile of Nothing -> return () Just fp -> liftIO $ void (reflectIDE (selectSourceBuf fp) ideR) -- | Build contextual menu on selected Descr descrViewContextMenu :: IDERef -> ForestStore Descr -> TypedTreeModelSort Descr -> TreeView -> Menu -> IO () descrViewContextMenu ideR store descrSortedStore descrView theMenu = do liftIO $ debugM "leksah" "descrViewContextMenu" item1 <- menuItemNewWithLabel (__ "Go to definition") onMenuItemActivate item1 $ do sel <- getSelectionDescr descrView store descrSortedStore case sel of Just descr -> reflectIDE (goToDefinition descr) ideR _ -> sysMessage Normal (__ "Modules>> descrViewPopup: no selection") item2 <- menuItemNewWithLabel (__ "Insert in buffer") onMenuItemActivate item2 $ do sel <- getSelectionDescr descrView store descrSortedStore case sel of Just descr -> reflectIDE (insertInBuffer descr) ideR _ -> sysMessage Normal (__ "Modules>> descrViewPopup: no selection") mapM_ (menuShellAppend theMenu) [item1, item2] -- | Selects the Descr referenced by the path descrViewSelect :: IDERef -> ForestStore Descr -> TypedTreeModelSort Descr -> TreePath -> TreeViewColumn -> IO () descrViewSelect ideR store descrSortedStore path _ = do liftIO $ debugM "leksah" "descrViewSelect" Just unsortedp <- treeModelSortConvertPathToChildPath descrSortedStore path descr <- forestStoreGetValue store unsortedp reflectIDE (goToDefinition descr) ideR setScope :: (Scope,Bool) -> IDEAction setScope (sc,bl) = do liftIO $ debugM "leksah" "setScope" mods <- getModules Nothing case sc of (PackageScope False) -> do toggleButtonSetActive (packageScopeB mods) True widgetSetSensitive (dependsB mods) True toggleButtonSetActive (dependsB mods) False (PackageScope True) -> do toggleButtonSetActive (packageScopeB mods) True widgetSetSensitive (dependsB mods) True toggleButtonSetActive (dependsB mods) True (WorkspaceScope False) -> do toggleButtonSetActive (workspaceScopeB mods) True widgetSetSensitive (dependsB mods) True toggleButtonSetActive (dependsB mods) False (WorkspaceScope True) -> do toggleButtonSetActive (workspaceScopeB mods) True widgetSetSensitive (dependsB mods) True toggleButtonSetActive (dependsB mods) True SystemScope -> do toggleButtonSetActive (systemScopeB mods) True widgetSetSensitive (dependsB mods) False toggleButtonSetActive (blacklistB mods) bl selectScope (sc,bl) getScope :: IDEM (Scope,Bool) getScope = do liftIO $ debugM "leksah" "getScope" mods <- getModules Nothing rb1s <- toggleButtonGetActive (packageScopeB mods) rb2s <- toggleButtonGetActive (workspaceScopeB mods) rb3s <- toggleButtonGetActive (systemScopeB mods) cb1s <- toggleButtonGetActive (dependsB mods) cbs <- toggleButtonGetActive (blacklistB mods) let scope | rb1s = PackageScope cb1s | rb2s = WorkspaceScope cb1s | otherwise = SystemScope return (scope,cbs) scopeSelection :: IDEAction scopeSelection = do liftIO $ debugM "leksah" "scopeSelection" (sc,bl) <- getScope setScope (sc,bl) selectScope (sc,bl) selectScope :: (Scope,Bool) -> IDEAction selectScope (sc,bl) = do liftIO $ debugM "leksah" "selectScope" recordExpanderState mods <- getModules Nothing mbTreeSelection <- getSelectionTree (treeView mods) (forestStore mods) mbDescrSelection <- getSelectionDescr (descrView mods) (descrStore mods) (descrSortedStore mods) ts <- treeViewGetSelection (treeView mods) withoutRecordingDo $ do treeSelectionUnselectAll ts fillModulesList (sc,bl) let mbs = (case mbTreeSelection of Just (_,Just (md,_)) -> Just (modu $ mdModuleId md) _ -> Nothing, case mbDescrSelection of Nothing -> Nothing Just fw -> Just (dscName fw)) selectNames mbs recordScopeHistory applyExpanderState bringPaneToFront mods selectNames :: (Maybe ModuleName, Maybe Text) -> IDEAction selectNames (mbModuleName, mbIdName) = do liftIO $ debugM "leksah" "selectIdentifier" mods <- getModules Nothing case mbModuleName of Nothing -> do sel <- treeViewGetSelection (treeView mods) treeSelectionUnselectAll sel selF <- treeViewGetSelection (descrView mods) treeSelectionUnselectAll selF Just moduleName -> let nameArray = map T.pack $ components moduleName in do mbTree <- forestStoreGetTreeSave (forestStore mods) =<< treePathNewFromIndices' [] case treePathFromNameArray mbTree nameArray [] of Nothing -> return () Just treePath' -> do treePath <- treePathNewFromIndices' (map fromIntegral treePath') treeViewExpandToPath (treeView mods) treePath sel <- treeViewGetSelection (treeView mods) treeSelectionSelectPath sel treePath Just col <- treeViewGetColumn (treeView mods) 0 treeViewScrollToCell (treeView mods) (Just treePath) (Just col) True 0.3 0.3 case mbIdName of Nothing -> do selF <- treeViewGetSelection (descrView mods) treeSelectionUnselectAll selF Just symbol -> do mbDescrTree <- forestStoreGetTreeSave (descrStore mods) =<< treePathNewFromIndices' [] selF <- treeViewGetSelection (descrView mods) case findPathFor symbol mbDescrTree of Nothing -> sysMessage Normal (__ "no path found") Just childPath -> do Just path <- treeModelSortConvertChildPathToPath (descrSortedStore mods) =<< treePathNewFromIndices' (map fromIntegral childPath) treeSelectionSelectPath selF path Just col <- treeViewGetColumn (descrView mods) 0 treeViewScrollToCell (descrView mods) (Just path) (Just col) True 0.3 0.3 reloadKeepSelection :: Bool -> IDEAction reloadKeepSelection isInitial = do liftIO . debugM "leksah" $ T.unpack (__ ">>>Info Changed!!! ") ++ show isInitial mbMod <- getPane case mbMod of Nothing -> return () Just mods -> do state <- readIDE currentState if not $ isStartingOrClosing state then do mbTreeSelection <- getSelectionTree (treeView mods) (forestStore mods) mbDescrSelection <- getSelectionDescr (descrView mods) (descrStore mods) (descrSortedStore mods) sc <- getScope recordExpanderState fillModulesList sc forestStoreClear (descrStore mods) let mbs = (case mbTreeSelection of Just (_,Just (md,_)) -> Just (modu $ mdModuleId md) _ -> Nothing, case mbDescrSelection of Nothing -> Nothing Just fw -> Just (dscName fw)) applyExpanderState selectNames mbs else when isInitial $ do SelectionState moduleS' facetS' sc bl <- liftIO $ readIORef (oldSelection mods) setScope (sc,bl) fillModulesList (sc, bl) selectNames (moduleS', facetS') applyExpanderState forestStoreGetTreeSave :: MonadIO m => ForestStore a -> TreePath -> m (Maybe (Tree a)) forestStoreGetTreeSave forestStore treePath = liftIO $ catch (do debugM "leksah" "forestStoreGetTreeSave" res <- forestStoreGetTree forestStore treePath return (Just res)) (\ (_ :: SomeException) -> return Nothing) expandHere :: TreeView -> IO () expandHere treeView = do liftIO $ debugM "leksah" "expandHere" sel <- treeViewGetSelection treeView paths <- treeSelectionGetSelectedRows' sel case paths of [] -> return () (hd:_) -> void (treeViewExpandRow treeView hd True) collapseHere :: TreeView -> IO () collapseHere treeView = do liftIO $ debugM "leksah" "collapseHere" sel <- treeViewGetSelection treeView paths <- treeSelectionGetSelectedRows' sel case paths of [] -> return () (hd:_) -> void (treeViewCollapseRow treeView hd) delModule :: TreeView -> ForestStore ModuleRecord -> PackageAction delModule treeview store = do liftIO $ debugM "leksah" "delModule" window <- liftIDE getMainWindow sel <- treeViewGetSelection treeview paths <- treeSelectionGetSelectedRows' sel categories <- case paths of [] -> return [] (treePath':_) -> do treePath <- treePathGetIndices' treePath' mapM (\n -> treePathNewFromIndices' (take n treePath) >>= forestStoreGetValue store) [1 .. length treePath] liftIDE $ ideMessage Normal (T.pack $ printf (__ "categories: %s") (show categories)) let modPacDescr = snd(last categories) case modPacDescr of Nothing -> liftIDE $ ideMessage Normal (__ "This should never be shown!") Just(md,_) -> do let modName = modu.mdModuleId $ md liftIDE $ ideMessage Normal ("modName: " <> T.pack (show modName)) delModuleFromPackageDescr modName respDelModDialog :: IDEM Bool respDelModDialog = do liftIO $ debugM "leksah" "respDelModDialog" window <- getMainWindow dia <- new' MessageDialog [ constructDialogUseHeaderBar 0, constructMessageDialogButtons ButtonsTypeCancel] setMessageDialogMessageType dia MessageTypeQuestion setMessageDialogText dia $ __ "Are you sure?" windowSetTransientFor dia (Just window) dialogAddButton' dia (__ "_Delete Module") (AnotherResponseType 1) dialogSetDefaultResponse' dia ResponseTypeCancel setWindowWindowPosition dia WindowPositionCenterOnParent resp <- dialogRun' dia widgetDestroy dia return $ resp == AnotherResponseType 1 addModule' :: TreeView -> ForestStore ModuleRecord -> PackageAction addModule' treeView store = do liftIO $ debugM "leksah" "addModule'" sel <- treeViewGetSelection treeView paths <- treeSelectionGetSelectedRows' sel categories <- case paths of [] -> return [] (treePath':_) -> do treePath <- treePathGetIndices' treePath' mapM (\n -> treePathNewFromIndices' (take n treePath) >>= forestStoreGetValue store) [1 .. length treePath] addModule (map fst categories) -- Includes non buildable allBuildInfo' :: PackageDescription -> [BuildInfo] allBuildInfo' pkg_descr = [ libBuildInfo lib | Just lib <- [library pkg_descr] ] ++ [ buildInfo exe | exe <- executables pkg_descr ] ++ [ testBuildInfo tst | tst <- testSuites pkg_descr ] ++ [ benchmarkBuildInfo tst | tst <- benchmarks pkg_descr ] addModule :: [Text] -> PackageAction addModule modulePrefix = do liftIO $ debugM "leksah" "selectIdentifier" mbPD <- liftIDE getPackageDescriptionAndPath case mbPD of Nothing -> liftIDE $ ideMessage Normal (__ "No package description") Just (pd,cabalPath) -> let srcPaths = nub $ concatMap hsSourceDirs $ allBuildInfo' pd rootPath = dropFileName cabalPath modPath = foldr (\a b -> a <> "." <> b) "" modulePrefix in do window' <- liftIDE getMainWindow mbResp <- addModuleDialog window' modPath srcPaths (hasLibs pd) $ map (T.pack . unUnqualComponentName . exeName) (executables pd) ++ map (T.pack . unUnqualComponentName . testName) (testSuites pd) ++ map (T.pack . unUnqualComponentName . benchmarkName) (benchmarks pd) case mbResp of Nothing -> return () Just addMod@(AddModule modPath srcPath libExposed exesAndTests) -> case simpleParse $ T.unpack modPath of Nothing -> liftIDE $ ideMessage Normal (T.pack $ printf (__ "Not a valid module name : %s") (T.unpack modPath)) Just moduleName -> do package <- ask let target = ipdPackageDir package srcPath toFilePath moduleName ++ ".hs" liftIO $ createDirectoryIfMissing True (dropFileName target) alreadyExists <- liftIO $ doesFileExist target if alreadyExists then do liftIDE $ ideMessage Normal (T.pack $ printf (__ "File already exists! Importing existing file %s.hs") (takeBaseName target)) addModuleToPackageDescr moduleName $ addModuleLocations addMod packageConfig else do template <- liftIO $ getEmptyModuleTemplate pd modPath liftIO $ T.writeFile target template addModuleToPackageDescr moduleName $ addModuleLocations addMod packageConfig liftIDE $ fileOpenThis target -- | The dialog for adding a new module data AddModule = AddModule { moduleName :: Text, sourceRoot :: FilePath, libExposed :: Maybe Bool, exesAndTests :: Set Text} addModuleLocations :: AddModule -> [ModuleLocation] addModuleLocations addMod = lib (libExposed addMod) ++ map ExeOrTestMod (Set.toList $ exesAndTests addMod) where lib (Just True) = [LibExposedMod] lib (Just False) = [LibOtherMod] lib Nothing = [] -- | Creates and runs a "new module" dialog addModuleDialog :: (Applicative m, MonadIO m) => Window -- ^ The parent window -> Text -- ^ Will be set as default value for the module name -> [FilePath] -- ^ Possible source directories to add it to -> Bool -- ^ Whether the active package has a library -> [Text] -- ^ The components of the active package -> m (Maybe AddModule) addModuleDialog parent modString sourceRoots hasLib exesTests = do liftIO $ debugM "leksah" "addModuleDialog" dia <- new' Dialog [constructDialogUseHeaderBar 1] setWindowTransientFor dia parent setWindowTitle dia $ __ "Construct new module" windowSetDefaultSize dia 400 100 upper <- dialogGetContentArea dia >>= liftIO . unsafeCastTo Box (widget,inj,ext,_) <- liftIO $ buildEditor (moduleFields sourceRoots hasLib exesTests) (AddModule modString (head sourceRoots) (Just False) Set.empty) okButton <- dialogAddButton' dia (__"Add Module") ResponseTypeOk >>= liftIO . unsafeCastTo Button dialogSetDefaultResponse' dia ResponseTypeOk dialogAddButton' dia (__"Cancel") ResponseTypeCancel errorLabel <- labelNew Nothing labelSetLineWrap errorLabel True widgetSetName errorLabel "errorLabel" onButtonClicked okButton $ do mbAddModule <- ext (AddModule modString (head sourceRoots) (Just False) Set.empty) case mbAddModule of Nothing -> return () Just am -> do let mbModName = simpleParse $ T.unpack (moduleName am) :: Maybe ModuleName case mbModName of Just _ -> dialogResponse' dia ResponseTypeOk Nothing -> do boxPackStart' upper errorLabel PackNatural 0 boxReorderChild upper errorLabel 0 labelSetText errorLabel "Invalid module name, use uppercase identifiers seperated by dots. For example Some.New.Module" widgetShow errorLabel boxPackStart' upper widget PackGrow 0 setWidgetCanDefault okButton True widgetGrabDefault okButton widgetShowAll dia resp <- dialogRun' dia value <- liftIO $ ext (AddModule modString (head sourceRoots) (Just False) Set.empty) widgetDestroy dia --find case resp of ResponseTypeOk -> return value _ -> return Nothing moduleFields :: [FilePath] -> Bool -> [Text] -> FieldDescription AddModule moduleFields list hasLibs exesTests = VFD emptyParams $ [ mkField (paraName <<<- ParaName (__ "New module ") $ emptyParams) moduleName (\ a b -> b{moduleName = a}) (textEditor (const True) True), mkField (paraName <<<- ParaName (__ "Root of the source path") $ paraMultiSel <<<- ParaMultiSel False $ paraMinSize <<<- ParaMinSize (-1, 120) $ emptyParams) (T.pack . sourceRoot) (\ a b -> b{sourceRoot = T.unpack a}) (staticListEditor (map T.pack list) id)] ++ [mkField (paraName <<<- ParaName (__ "Library should") $ emptyParams) libExposed (\ a b -> b{libExposed = a}) (maybeEditor (boolEditor, paraName <<<- ParaName (__ "Expose module") $ emptyParams) True (__ "Include module")) | hasLibs] ++ map (\ name -> mkField (paraName <<<- ParaName (__ "Include in " <> name) $ emptyParams) (Set.member name . exesAndTests) (\ a b -> b{exesAndTests = (if a then Set.insert else Set.delete) name (exesAndTests b)}) boolEditor) exesTests -- * Expander State emptyExpansion = ExpanderState ([],[]) ([],[]) ([],[]) ([],[]) ([],[]) ([],[]) ([],[]) ([],[]) ([],[]) ([],[]) recordExpanderState :: IDEAction recordExpanderState = do liftIO $ debugM "leksah" "recordExpanderState" m <- getModules Nothing liftIO $ do oldSel <- readIORef (oldSelection m) let (sc,bl) = (scope' oldSel, blacklist' oldSel) paths1 <- getExpandedRows (treeView m) (forestStore m) paths2 <- getExpandedRows (descrView m) (descrStore m) modifyIORef (expanderState m) (\ es -> case (sc,bl) of (PackageScope False, True) -> es{packageExp = (paths1,paths2)} (PackageScope False, False) -> es{packageExpNoBlack = (paths1,paths2)} (PackageScope True, True) -> es{packageDExp = (paths1,paths2)} (PackageScope True, False) -> es{packageDExpNoBlack = (paths1,paths2)} (WorkspaceScope False, True) -> es{workspaceExp = (paths1,paths2)} (WorkspaceScope False, False) -> es{workspaceExpNoBlack = (paths1,paths2)} (WorkspaceScope True,True) -> es{workspaceDExp = (paths1,paths2)} (WorkspaceScope True,False) -> es{workspaceDExpNoBlack = (paths1,paths2)} (SystemScope,True) -> es{systemExp = (paths1,paths2)} (SystemScope,False) -> es{systemExpNoBlack = (paths1,paths2)}) st <- readIORef (expanderState m) return () getExpandedRows :: TreeView -> ForestStore alpha -> IO [[Int]] getExpandedRows view store = do liftIO $ debugM "leksah" "getExpandedRows" mbIter <- treeModelGetIterFirst store case mbIter of (False, _) -> return [] (True, iter) -> expandedFor iter [] >>= mapM (fmap (map fromIntegral) . treePathGetIndices') where expandedFor :: TreeIter -> [TreePath] -> IO [TreePath] expandedFor iter accu = do path <- treeModelGetPath store iter expanded <- treeViewRowExpanded view path res <- if expanded then do mbIter <- treeModelIterChildren store (Just iter) case mbIter of (False, _) -> return (path : accu) (True, iter) -> expandedFor iter (path : accu) else return accu treeModelIterNext store iter >>= \case False -> return res True -> expandedFor iter res applyExpanderState :: IDEAction applyExpanderState = do liftIO $ debugM "leksah" "applyExpanderState" m <- getModules Nothing (sc,bl) <- getScope liftIO $ do es <- readIORef (expanderState m) let (paths1,paths2) = case (sc,bl) of (PackageScope False, True) -> packageExp es (PackageScope False, False) -> packageExpNoBlack es (PackageScope True,True) -> packageDExp es (PackageScope True,False) -> packageDExpNoBlack es (WorkspaceScope False, True) -> workspaceExp es (WorkspaceScope False, False) -> workspaceExpNoBlack es (WorkspaceScope True,True) -> workspaceDExp es (WorkspaceScope True,False) -> workspaceDExpNoBlack es (SystemScope,True) -> systemExp es (SystemScope,False) -> systemExpNoBlack es mapM_ (\p -> treePathNewFromIndices' (map fromIntegral p) >>= treeViewExpandToPath (treeView m)) paths1 mapM_ (\p -> treePathNewFromIndices' (map fromIntegral p) >>= treeViewExpandToPath (descrView m)) paths2 -- * GUI History recordSelHistory :: IDEAction recordSelHistory = do liftIO $ debugM "leksah" "selectIdentifier" mods <- getModules Nothing ideR <- ask selTree <- getSelectionTree (treeView mods) (forestStore mods) selDescr <- getSelectionDescr (descrView mods) (descrStore mods) (descrSortedStore mods) let selMod = case selTree of Just (_,Just (md,_)) -> Just (modu $ mdModuleId md) _ -> Nothing let selFacet = case selDescr of Nothing -> Nothing Just descr -> Just (dscName descr) oldSel <- liftIO $ readIORef (oldSelection mods) triggerEventIDE (RecordHistory (ModuleSelected selMod selFacet, ModuleSelected (moduleS' oldSel) (facetS' oldSel))) liftIO $ writeIORef (oldSelection mods) (oldSel{moduleS'= selMod, facetS' = selFacet}) return () replaySelHistory :: Maybe ModuleName -> Maybe Text -> IDEAction replaySelHistory mbModName mbFacetName = do liftIO $ debugM "leksah" "replaySelHistory" mods <- getModules Nothing selectNames (mbModName, mbFacetName) oldSel <- liftIO $ readIORef (oldSelection mods) liftIO $ writeIORef (oldSelection mods) (oldSel{moduleS'= mbModName, facetS' = mbFacetName}) recordScopeHistory :: IDEAction recordScopeHistory = do liftIO $ debugM "leksah" "recordScopeHistory" (sc,bl) <- getScope ideR <- ask mods <- getModules Nothing oldSel <- liftIO $ readIORef (oldSelection mods) triggerEventIDE (RecordHistory (ScopeSelected sc bl, ScopeSelected (scope' oldSel) (blacklist' oldSel))) liftIO $ writeIORef (oldSelection mods) (oldSel{scope'= sc, blacklist' = bl}) return () replayScopeHistory :: Scope -> Bool -> IDEAction replayScopeHistory sc bl = do liftIO $ debugM "leksah" "selectIdentifier" mods <- getModules Nothing liftIO $ do toggleButtonSetActive (blacklistB mods) bl toggleButtonSetActive (packageScopeB mods) (sc == PackageScope False) toggleButtonSetActive (workspaceScopeB mods) (sc == PackageScope True) toggleButtonSetActive (systemScopeB mods) (sc == SystemScope) setScope (sc,bl) oldSel <- liftIO $ readIORef (oldSelection mods) liftIO $ writeIORef (oldSelection mods) (oldSel{scope'= sc, blacklist' = bl})