leksah-0.4.4: src/IDE/Pane/ClassHierarchy.hs
{-# OPTIONS_GHC -XDeriveDataTypeable -XMultiParamTypeClasses -XTypeSynonymInstances
-XScopedTypeVariables #-}
-----------------------------------------------------------------------------
--
-- Module : IDE.Pane.ClassHierarchy
-- Copyright : (c) Juergen Nicklisch-Franken, Hamish Mackenzie
-- License : GNU-GPL
--
-- Maintainer : <maintainer at leksah.org>
-- Stability : provisional
-- Portability : portable
--
-- | The pane of ide where modules are presented in tree form with their
-- packages and exports
--
-------------------------------------------------------------------------------
module IDE.Pane.ClassHierarchy (
IDEClassHierarchy(..)
, ClassHierarchyState(..)
, showClasses
--, showInstances
, selectClass
--, reloadKeepSelection
) where
import Graphics.UI.Gtk hiding (get)
import Data.Maybe
import Control.Monad.Reader
import qualified Data.Map as Map
import Data.Tree
import Data.List
import Data.Typeable
import Prelude hiding (catch)
import IDE.Core.State
-- | A modules pane description
--
data IDEClassHierarchy = IDEClassHierarchy {
outer :: VBox
, paned :: HPaned
, treeView :: TreeView
, treeStore :: TreeStore ClassWrapper
--, facetView :: TreeView
--, facetStore :: TreeStore FacetWrapper
, localScopeB :: RadioButton
, packageScopeB :: RadioButton
, worldScopeB :: RadioButton
, blacklistB :: CheckButton
} deriving Typeable
data ClassHierarchyState = ClassHierarchyState Int (Scope,Bool)
(Maybe String, Maybe String)
deriving(Eq,Ord,Read,Show,Typeable)
instance IDEObject IDEClassHierarchy
instance Pane IDEClassHierarchy IDEM
where
primPaneName _ = "ClassHierarchy"
getAddedIndex _ = 0
getTopWidget = castToWidget . outer
paneId b = "*ClassHierarchy"
makeActive p = activatePane p []
close = closePane
instance RecoverablePane IDEClassHierarchy ClassHierarchyState IDEM where
saveState p = return Nothing
recoverState pp _ = return ()
{--
instance RecoverablePane IDEClassHierarchy ClassHierarchyState where
saveState p = do
(IDEModules _ _ treeView treeStore facetView facetStore _ _ _ _) <- getModules
sc <- getScope
mbModules <- getPane
case mbModules of
Nothing -> return Nothing
Just p -> liftIO $ do
i <- panedGetPosition (paned p)
mbTreeSelection <- getSelectionTree treeView treeStore
mbFacetSelection <- getSelectionFacet facetView facetStore
let mbs = (case mbTreeSelection of
Nothing -> Nothing
Just (_,[]) -> Nothing
Just (_,((md,_):_)) -> Just (modu $ moduleIdMD md),
case mbFacetSelection of
Nothing -> Nothing
Just fw -> Just (symbolFromFacetWrapper fw))
return (Just (ModulesState i sc mbs))
recoverState pp (ModulesState i sc@(scope,useBlacklist) se) = do
nb <- getNotebook pp
initModules pp nb
mod@(IDEModules _ _ treeView treeStore facetView facetStore lb pb wb blb)
<- getModules
case scope of
Local -> liftIO $ toggleButtonSetActive lb True
Package -> liftIO $ toggleButtonSetActive pb True
World -> liftIO $ toggleButtonSetActive wb True
liftIO $ toggleButtonSetActive blb useBlacklist
liftIO $ panedSetPosition (paned mod) i
fillModulesList sc
selectNames se
--}
selectClass :: Descr -> IDEAction
selectClass d@(Descr descrName _ descrModu _ _ details) =
case details of
(ClassDescr _ _)-> selectClass' (modu descrModu) descrName
_ -> return ()
selectClass _ = return ()
selectClass' moduleName symbol = return ()
{--
selectClass' :: ModuleIdentifier -> Symbol -> IDEAction
selectClass' moduleName symbol =
let nameArray = breakAtDots [] moduleName
in do
mods@(IDEModules _ _ treeView treeStore facetView facetStore _ _ _ _) <- getModules
mbTree <- liftIO $ treeStoreGetTreeSave treeStore []
case treePathFromNameArray mbTree nameArray [] of
Just treePath -> liftIO $ do
treeViewExpandToPath treeView treePath
sel <- treeViewGetSelection treeView
treeSelectionSelectPath sel treePath
col <- treeViewGetColumn treeView 0
treeViewScrollToCell treeView treePath (fromJust col) (Just (0.3,0.3))
mbFacetTree <- treeStoreGetTreeSave facetStore []
selF <- treeViewGetSelection facetView
case findPathFor symbol mbFacetTree of
Nothing -> sysMessage Normal "no path found"
Just path -> do
treeSelectionSelectPath selF path
col <- treeViewGetColumn facetView 0
treeViewScrollToCell facetView path (fromJust col) (Just (0.3,0.3))
bringPaneToFront mods
Nothing -> return ()
--}
showClasses :: IDEAction
showClasses = do
m <- getClassHierarchy
liftIO $ bringPaneToFront m
liftIO $ widgetGrabFocus (treeView m)
--showInstances :: IDEAction
--showInstances = do
-- m <- getClassHierarchy
-- liftIO $ bringPaneToFront m
-- liftIO $ widgetGrabFocus (facetView m)
getClassHierarchy :: IDEM IDEClassHierarchy
getClassHierarchy = do
mbCH <- getPane
case mbCH of
Nothing -> do
prefs <- readIDE prefs
layout <- readIDE layout
let pp = getStandardPanePath (modulesPanePath prefs) layout
nb <- getNotebook pp
initClassHierarchy pp nb
mbCH <- getPane
case mbCH of
Nothing -> throwIDE "Can't init class hierarchy"
Just m -> return m
Just m -> return m
type ClassHierarchy = Forest ClassWrapper
type ClassWrapper = (Symbol, [Symbol], Descr)
--
-- | Make a Tree with a class hierarchy for display.
--
buildClassHierarchyTree :: (PackageScope,PackageScope) -> ClassHierarchy
buildClassHierarchyTree ((_,sc1),(_,sc2)) =
let allClasses = nub
$ filter isClassDescr
$ concat (Map.elems sc1)
++ concat (Map.elems sc2)
wrappers = map asClassWrapper allClasses
(basics,other) = partition (\(_,sc,_) -> null sc) wrappers
basicForest = map (\ n -> Node n []) basics
resultForest = insertInForest basicForest other
in sortForest resultForest
where
insertInForest :: ClassHierarchy -> [ClassWrapper] -> ClassHierarchy
insertInForest basicForest [] = basicForest
insertInForest basicForest other =
let (newForest,rest) = foldl' insertInForest' (basicForest,[]) other
in if length rest >= length other
then throwIDE "ClassHierarchy>>buildClassHierarchyTree: Can't build tree"
else insertInForest newForest rest
insertInForest' :: (ClassHierarchy,[ClassWrapper]) -> ClassWrapper
-> (ClassHierarchy,[ClassWrapper])
insertInForest' (forest,rest) wrap@(id,superList,idDescr) =
let (newForest,newSuperList) = foldl' (insertInForest2 wrap)
(forest, []) superList
in if null newSuperList
then (newForest,rest)
else (newForest,(id,newSuperList,idDescr): rest)
insertInForest2 :: ClassWrapper -> (ClassHierarchy,[String]) -> String
-> (ClassHierarchy,[String])
insertInForest2 wrapper (forest,rest) super =
let (newForest,success) = foldl' (insertInTree wrapper super) ([],False) forest
in if success
then (newForest,rest)
else (newForest, super : rest)
insertInTree :: ClassWrapper -> String -> (ClassHierarchy,Bool)
-> Tree ClassWrapper -> (ClassHierarchy,Bool)
insertInTree wrapper superS (forest,bool) n@(Node w@(symbol,super,idDescr) subForest) =
if superS == symbol
then (Node w ((Node wrapper []) : subForest) : forest, True)
else
let (newSubForest,newBool) = foldl' (insertInTree wrapper superS) ([],False)
subForest
in if newBool
then ((Node w newSubForest) : forest, True)
else (n: forest, bool)
isClassDescr :: Descr -> Bool
isClassDescr descr = case details descr of
ClassDescr _ _ -> True
_ -> False
asClassWrapper :: Descr -> ClassWrapper
asClassWrapper descr =
case details descr of
ClassDescr super _ -> (descrName descr, super, descr)
_ -> throwIDE "ClassHierarchy>>asClassWrapper: No class"
instance Ord a => Ord (Tree a) where
compare (Node l1 _) (Node l2 _) = compare l1 l2
sortForest :: Ord a => Forest a -> Forest a
sortForest forest = sort (map sortTree forest)
sortTree :: Ord a => Tree a -> Tree a
sortTree (Node l forest) = Node l (sort (map sortTree forest))
initClassHierarchy :: PanePath -> Notebook -> IDEAction
initClassHierarchy panePath nb = do
panes <- readIDE panes
paneMap <- readIDE paneMap
prefs <- readIDE prefs
currentInfo <- readIDE currentInfo
(buf,cids) <- reifyIDE $ \ideR -> do
-- Class Hierarchy
let forest = case currentInfo of
Nothing -> []
Just pair -> buildClassHierarchyTree pair
treeStore <- treeStoreNew forest
treeView <- treeViewNew
treeViewSetModel treeView treeStore
--treeViewSetRulesHint treeView True
renderer0 <- cellRendererPixbufNew
set renderer0 [ cellPixbufStockId := "ide_no_source" ]
renderer <- cellRendererTextNew
col <- treeViewColumnNew
treeViewColumnSetTitle col "Classes"
treeViewColumnSetSizing col TreeViewColumnAutosize
treeViewColumnSetResizable col True
treeViewColumnSetReorderable col True
treeViewAppendColumn treeView col
cellLayoutPackStart col renderer0 False
cellLayoutPackStart col renderer True
cellLayoutSetAttributes col renderer treeStore
$ \(s,_,_) -> [ cellText := s]
cellLayoutSetAttributes col renderer0 treeStore
$ \(_,_,d) -> [
cellPixbufStockId :=
if isJust (mbLocation d)
then "ide_source"
else "ide_no_source"]
treeViewSetHeadersVisible treeView True
-- treeViewSetEnableSearch treeView True
-- treeViewSetSearchColumn treeView 0
-- treeViewSetSearchEqualFunc treeView (treeViewSearch treeView treeStore)
-- Facet view
{--
facetView <- treeViewNew
facetStore <- treeStoreNew []
treeViewSetModel facetView facetStore
renderer30 <- cellRendererPixbufNew
renderer31 <- cellRendererPixbufNew
renderer3 <- cellRendererTextNew
col <- treeViewColumnNew
treeViewColumnSetTitle col "Interface"
--treeViewColumnSetSizing col TreeViewColumnAutosize
treeViewAppendColumn facetView col
cellLayoutPackStart col renderer30 False
cellLayoutPackStart col renderer31 False
cellLayoutPackStart col renderer3 True
cellLayoutSetAttributes col renderer3 facetStore
$ \row -> [ cellText := facetTreeText row]
cellLayoutSetAttributes col renderer30 facetStore
$ \row -> [
cellPixbufStockId := stockIdFromType (facetIdType row)]
cellLayoutSetAttributes col renderer31 facetStore
$ \row -> [
cellPixbufStockId := if isJust (mbLocation(facetIdDescr row))
then "ide_source"
else ""]
treeViewSetHeadersVisible facetView True
treeViewSetEnableSearch facetView True
treeViewSetSearchColumn facetView 0
treeViewSetSearchEqualFunc facetView (facetViewSearch facetView facetStore)
--}
pane' <- hPanedNew
sw <- scrolledWindowNew Nothing Nothing
containerAdd sw treeView
scrolledWindowSetPolicy sw PolicyAutomatic PolicyAutomatic
{-- sw2 <- scrolledWindowNew Nothing Nothing
containerAdd sw2 facetView
scrolledWindowSetPolicy sw2 PolicyAutomatic PolicyAutomatic--}
panedAdd1 pane' sw
-- panedAdd2 pane' sw2
(x,y) <- widgetGetSize nb
panedSetPosition pane' (x `quot` 2)
box <- hBoxNew True 2
rb1 <- radioButtonNewWithLabel "Local"
rb2 <- radioButtonNewWithLabelFromWidget rb1 "Package"
rb3 <- radioButtonNewWithLabelFromWidget rb1 "World"
toggleButtonSetActive rb3 True
cb <- checkButtonNewWithLabel "Blacklist"
boxPackStart box rb1 PackGrow 2
boxPackStart box rb2 PackGrow 2
boxPackStart box rb3 PackGrow 2
boxPackEnd box cb PackNatural 2
boxOuter <- vBoxNew False 2
boxPackStart boxOuter box PackNatural 2
boxPackStart boxOuter pane' PackGrow 2
let classes = IDEClassHierarchy boxOuter pane' treeView treeStore
{--facetView facetStore--} rb1 rb2 rb3 cb
notebookInsertOrdered nb boxOuter (paneName classes) Nothing
widgetShowAll boxOuter
cid3 <- treeView `onRowActivated`
(\ treePath _ -> do
treeViewExpandRow treeView treePath False
return ())
cid1 <- treeView `afterFocusIn`
(\_ -> do reflectIDE (makeActive classes) ideR; return True)
-- cid2 <- facetView `afterFocusIn`
-- (\_ -> do runReaderT (makeActive classes) ideR; return True)
-- treeView `onButtonPress` (treeViewPopup ideR treeStore treeView)
-- facetView `onButtonPress` (facetViewPopup ideR facetStore facetView)
-- rb1 `onToggled` (runReaderT scopeSelection ideR)
-- rb2 `onToggled` (runReaderT scopeSelection ideR)
-- rb3 `onToggled` (runReaderT scopeSelection ideR)
-- cb `onToggled` (runReaderT scopeSelection ideR)
sel <- treeViewGetSelection treeView
-- sel `onSelectionChanged` (fillFacets treeView treeStore facetView facetStore)
-- sel2 <- treeViewGetSelection facetView
-- sel2 `onSelectionChanged` (fillInfo facetView facetStore ideR)
return (classes,[ConnectC cid1{--,ConnectC cid2--}, ConnectC cid3])
addPaneAdmin buf cids panePath
liftIO $widgetGrabFocus (paned buf)
{--
treeViewSearch :: TreeView
-> TreeStore (String, [(ModuleDescr,PackageDescr)])
-> Int
-> String
-> TreeIter
-> IO Bool
treeViewSearch treeView treeStore _ string iter = do
path <- treeModelGetPath treeStore iter
val <- treeStoreGetValue treeStore path
mbTree <- treeStoreGetTreeSave treeStore 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
[] -> fst val
(m,_):_ -> showPackModule (moduleIdMD m)
return (isInfixOf (map toLower string) (map toLower str2))
searchInModSubnodes :: ModTree -> String -> Bool
searchInModSubnodes tree str =
not $ null
$ filter (\ val ->
let cstr = case snd val of
[] -> fst val
(m,_):_ -> showPackModule (moduleIdMD m)
in isInfixOf (map toLower str) (map toLower cstr))
$ concatMap flatten (subForest tree)
facetViewSearch :: TreeView
-> TreeStore FacetWrapper
-> Int
-> String
-> TreeIter
-> IO Bool
facetViewSearch facetView facetStore _ string iter = do
path <- treeModelGetPath facetStore iter
val <- treeStoreGetValue facetStore path
tree <- treeStoreGetTree facetStore path
exp <- treeViewRowExpanded facetView path
when (not (null (subForest tree)) && not exp) $
let found = searchInFacetSubnodes tree string
in when found $ do
treeViewExpandRow facetView path False
return ()
return (isInfixOf (map toLower string) (map toLower (facetTreeText val)))
searchInFacetSubnodes :: FacetTree -> String -> Bool
searchInFacetSubnodes tree str =
not $ null
$ filter (\ val ->
isInfixOf (map toLower str) (map toLower (facetTreeText val)))
$ concatMap flatten (subForest tree)
--}
{--
fillFacets :: TreeView
-> TreeStore (String, [(ModuleDescr,PackageDescr)])
-> TreeView
-> TreeStore FacetWrapper
-> IO ()
fillFacets treeView treeStore facetView facetStore = do
sel <- getSelectionTree treeView treeStore
case sel of
Just val
-> case snd val of
((mod,package):_)
-> let forest = buildFacetForest mod in do
emptyModel <- treeStoreNew []
treeViewSetModel facetView emptyModel
treeStoreClear facetStore
mapM_ (\(e,i) -> treeStoreInsertTree facetStore [] i e)
$ zip forest [0 .. length forest]
treeViewSetModel facetView facetStore
treeViewSetEnableSearch facetView True
treeViewSetSearchColumn facetView 0
treeViewSetSearchEqualFunc facetView (facetViewSearch facetView facetStore)
[] -> return ()
Nothing
-> do
treeStoreClear facetStore
return ()
--}
{--
getSelectionTree :: TreeView
-> TreeStore (String, [(ModuleDescr,PackageDescr)])
-> IO (Maybe (String, [(ModuleDescr,PackageDescr)]))
getSelectionTree treeView treeStore = do
treeSelection <- treeViewGetSelection treeView
paths <- treeSelectionGetSelectedRows treeSelection
case paths of
[] -> return Nothing
a:r -> do
val <- treeStoreGetValue treeStore a
return (Just val)
getSelectionFacet :: TreeView
-> TreeStore FacetWrapper
-> IO (Maybe FacetWrapper)
getSelectionFacet treeView treeStore = do
treeSelection <- treeViewGetSelection treeView
paths <- treeSelectionGetSelectedRows treeSelection
case paths of
a:r -> do
val <- treeStoreGetValue treeStore a
return (Just val)
_ -> return Nothing
fillInfo :: TreeView
-> TreeStore FacetWrapper
-> IDERef
-> IO ()
fillInfo treeView lst ideR = do
treeSelection <- treeViewGetSelection treeView
paths <- treeSelectionGetSelectedRows treeSelection
case paths of
[] -> return ()
[a] -> do
wrapper <- treeStoreGetValue lst a
runReaderT (setInfos [facetIdDescr wrapper]) ideR
return ()
_ -> return ()
findDescription :: PackModule -> SymbolTable -> Symbol -> Maybe (Symbol,IdentifierDescr)
findDescription md st s =
case Map.lookup s st of
Nothing -> Nothing
Just l -> case filter (\id -> md == moduleIdID id) l of
[] -> Nothing
l -> Just (s,head l)
fillModulesList :: (Scope,Bool) -> IDEAction
fillModulesList (scope,useBlacklist) = do
(IDEModules _ _ treeView treeStore _ _ _ _ _ _) <- getModules
prefs <- readIDE prefs
currentInfo' <- readIDE currentInfo
accessibleInfo' <- readIDE accessibleInfo
case currentInfo' of
Nothing -> case (scope,accessibleInfo') of
(World,Just ai@(pm,ps)) ->
let p2 = if useBlacklist
then (Map.filter (filterBlacklist
(packageBlacklist prefs)) pm, ps)
else ai
(Node _ li) = buildModulesTree
((Map.empty,Map.empty),p2)
in liftIO $ do
treeStoreClear treeStore
mapM_ (\(e,i) -> treeStoreInsertTree treeStore [] i e)
$ zip li [0 .. length li]
_ -> liftIO $ do
treeStoreClear treeStore
treeStoreInsertTree treeStore [] 0 (Node ("",[]) [])
Just (l,p) -> let (l',p'@(pm,ps)) = case scope of
Local -> (l,(Map.empty,Map.empty))
Package -> (l,p)
World -> case accessibleInfo' of
Just ai -> (l,ai)
Nothing -> (l,p)
p2 = if useBlacklist
then (Map.filter (filterBlacklist
(packageBlacklist prefs)) pm, ps)
else p'
(Node _ li) = buildModulesTree (l',p2)
in liftIO $ do
emptyModel <- treeStoreNew []
treeViewSetModel treeView emptyModel
treeStoreClear treeStore
mapM_ (\(e,i) -> treeStoreInsertTree treeStore [] i e)
$ zip li [0 .. length li]
treeViewSetModel treeView treeStore
treeViewSetEnableSearch treeView True
treeViewSetSearchColumn treeView 0
treeViewSetSearchEqualFunc treeView (treeViewSearch treeView treeStore)
where
filterBlacklist :: [Dependency] -> PackageDescr -> Bool
filterBlacklist dependencies packageDescr =
let packageId = packagePD packageDescr
name = pkgName packageId
version = pkgVersion packageId
in isNothing $ find (\ (Dependency str vr) -> str == name && withinRange version vr)
dependencies
type FacetForest = Forest FacetWrapper
type FacetTree = Tree FacetWrapper
facetTreeText :: FacetWrapper -> String
facetTreeText (Itself (SimpleDescr id FunctionS _ _ _ _)) = {-- "function " ++ --} id
facetTreeText (Itself (SimpleDescr id NewtypeS _ _ _ _)) = {-- "newtype " ++ --} id
facetTreeText (Itself (SimpleDescr id TypeS _ _ _ _)) = {-- "type " ++ --} id
facetTreeText (Itself (SimpleDescr id _ _ _ _ _)) = id
facetTreeText (Itself (DataDescr id _ _ _ _ _ _)) = {-- "data " ++ --} id
facetTreeText (Itself (ClassDescr id _ _ _ _ _)) = {-- "class " ++ --} id
facetTreeText (Itself (InstanceDescr cl _ _ _ _ )) = {-- "instance " ++ --} cl
facetTreeText (ConstructorW s _) = {-- "constructor " ++ --} s
facetTreeText (FieldW s _) = {-- "slot " ++ --} s
facetTreeText (MethodW s _) = {-- "method " ++ --} s
facetTreeText (OrphanedData (InstanceDescr cl binds _ _ _)) = {-- "instance " ++ --} cl
++ " " ++ printBinds binds
where
printBinds [] = ""
printBinds (a:[]) = a
printBinds (a:b) = a ++ " " ++ printBinds b
facetTreeText _ = throwIDE "impossible in facetTreeText"
facetIdType :: FacetWrapper -> IdType
facetIdType (Itself descr) = idType descr
facetIdType (ConstructorW _ _) = Constructor
facetIdType (FieldW _ _) = Field
facetIdType (MethodW _ _) = Method
facetIdType (OrphanedData _) = OrphanedInstance
facetIdDescr :: FacetWrapper -> IdentifierDescr
facetIdDescr (Itself descr) = descr
facetIdDescr (ConstructorW _ descr) = descr
facetIdDescr (FieldW _ descr) = descr
facetIdDescr (MethodW _ descr) = descr
facetIdDescr (OrphanedData descr) = descr
buildFacetForest :: ModuleDescr -> FacetForest
buildFacetForest modDescr =
let (instances,other) = partition (\id -> case id of
InstanceDescr _ _ _ _ _ -> True
_ -> False)
$ idDescriptionsMD modDescr
forestWithoutInstances = map buildFacet other
(forest2,orphaned) = foldl' addInstances (forestWithoutInstances,[])
instances
orphanedNodes = map (\ inst -> Node (OrphanedData inst) []) orphaned
in forest2 ++ reverse orphanedNodes
where
buildFacet :: IdentifierDescr -> FacetTree
buildFacet d@(SimpleDescr _ _ _ _ _ _)
= Node (Itself d) []
buildFacet d@(DataDescr _ _ _ constID fieldsID _ _)
= (Node (Itself d) ((map (\ s -> Node (ConstructorW s d) []) constID)
++ (map (\ s -> Node (FieldW s d) []) fieldsID)))
buildFacet d@(ClassDescr _ _ _ classOpsID _ _)
= Node (Itself d) (map (\ s -> Node (MethodW s d) []) classOpsID)
buildFacet d@(InstanceDescr _ _ _ _ _)
= throwIDE "Impossible in buildFacet"
addInstances :: (FacetForest,[IdentifierDescr])
-> IdentifierDescr
-> (FacetForest,[IdentifierDescr])
addInstances (forest,orphaned) instDescr =
case foldl' (matches instDescr) ([],False) forest of
(f,True) -> (f,orphaned)
(f,False) -> (forest, instDescr:orphaned)
matches :: IdentifierDescr
-> (FacetForest,Bool)
-> FacetTree
-> (FacetForest,Bool)
matches instDescr (forest,False) (Node (Itself dd@(DataDescr id _ _ _ _ _ _)) sub)
| [id] == binds instDescr
= ((Node (Itself dd) (sub ++ [Node (Itself instDescr) []])):forest,True)
matches instDescr (forest,False) (Node (Itself dd@(SimpleDescr id ty _ _ _ _ )) sub)
| [id] == binds instDescr && ty == NewtypeS
= ((Node (Itself dd) (sub ++ [Node (Itself instDescr) []])):forest,True)
matches _ (forest,b) node = (node:forest,b)
--}
{--
treeViewPopup :: IDERef
-> TreeStore (String, [(ModuleDescr,PackageDescr)])
-> TreeView
-> Event
-> IO (Bool)
treeViewPopup ideR store treeView (Button _ click _ _ _ _ button _ _) = do
if button == RightButton
then do
theMenu <- menuNew
item1 <- menuItemNewWithLabel "Edit"
item1 `onActivateLeaf` do
sel <- getSelectionTree treeView store
case sel of
Just (_,[(m,_)]) -> case mbSourcePathMD m of
Nothing -> return ()
Just fp -> do
runReaderT (selectSourceBuf fp) ideR
return ()
otherwise -> return ()
item2 <- menuItemNewWithLabel "ExpandAll"
item2 `onActivateLeaf` (treeViewExpandAll treeView)
item3 <- menuItemNewWithLabel "CollapseAll"
item3 `onActivateLeaf` (treeViewCollapseAll treeView)
mapM_ (menuShellAppend theMenu) [item1,item2,item3]
menuPopup theMenu Nothing
widgetShowAll theMenu
return True
else if button == LeftButton && click == DoubleClick
then do sel <- getSelectionTree treeView store
case sel of
Just (_,[(m,_)]) -> case mbSourcePathMD m of
Nothing -> return ()
Just fp -> do
runReaderT (selectSourceBuf fp) ideR
return ()
otherwise -> return ()
return True
else return False
treeViewPopup _ _ _ _ = throwIDE "treeViewPopup wrong event type"
facetViewPopup :: IDERef
-> TreeStore FacetWrapper
-> TreeView
-> Event
-> IO (Bool)
facetViewPopup ideR store facetView (Button _ click _ _ _ _ button _ _) = do
if button == RightButton
then do
theMenu <- menuNew
item1 <- menuItemNewWithLabel "Go to definition"
item1 `onActivateLeaf` do
sel <- getSelectionFacet facetView store
case sel of
Just wrapper -> runReaderT
(goToDefinition (facetIdDescr wrapper)) ideR
otherwise -> sysMessage Normal "no selection"
menuShellAppend theMenu item1
menuPopup theMenu Nothing
widgetShowAll theMenu
return True
else if button == LeftButton && click == DoubleClick
then do sel <- getSelectionFacet facetView store
case sel of
Just wrapper -> runReaderT (goToDefinition
(facetIdDescr wrapper)) ideR
otherwise -> sysMessage Normal "no selection"
return True
else do
mbPane :: Maybe IDEInfo <- runReaderT getPane ideR
when (isJust mbPane) $ bringPaneToFront (fromJust mbPane)
return False
facetViewPopup _ _ _ _ = throwIDE "facetViewPopup wrong event type"
--}
{--
getScope :: IDEM (Scope,Bool)
getScope = do
(IDEModules _ _ treeView treeStore facetView facetStore localScopeB
packageScopeB worldScopeB blacklistB) <- getModules
rb1s <- liftIO $ toggleButtonGetActive localScopeB
rb2s <- liftIO $ toggleButtonGetActive packageScopeB
rb3s <- liftIO $ toggleButtonGetActive worldScopeB
cbs <- liftIO $ toggleButtonGetActive blacklistB
let scope = if rb1s
then Local
else if rb2s
then Package
else if rb3s
then World
else throwIDE
"ModulesPane.scopeSelection: No check button selected"
return (scope,cbs)
scopeSelection :: IDEAction
scopeSelection = do
mods@(IDEModules _ _ treeView treeStore facetView facetStore _ _ _ _)
<- getModules
mbTreeSelection <- liftIO $ getSelectionTree treeView treeStore
mbFacetSelection <- liftIO $ getSelectionFacet facetView facetStore
sc <- getScope
ts <- liftIO $ treeViewGetSelection treeView
liftIO $ treeSelectionUnselectAll ts
fillModulesList sc
let mbs = (case mbTreeSelection of
Nothing -> Nothing
Just (_,[]) -> Nothing
Just (_,((md,_):_)) -> Just (modu $ moduleIdMD md),
case mbFacetSelection of
Nothing -> Nothing
Just fw -> Just (symbolFromFacetWrapper fw))
selectNames mbs
liftIO $ bringPaneToFront mods
selectNames :: (Maybe String, Maybe Symbol) -> IDEAction
selectNames (mbModuleName, mbIdName) = do
(IDEModules _ _ treeView treeStore facetView facetStore _ _ _ _)
<- getModules
case mbModuleName of
Nothing -> return ()
Just moduleName ->
let nameArray = breakAtDots [] moduleName
in do
mbTree <- liftIO $ treeStoreGetTreeSave treeStore []
case treePathFromNameArray mbTree nameArray [] of
Nothing -> return ()
Just treePath -> liftIO $ do
treeViewExpandToPath treeView treePath
sel <- treeViewGetSelection treeView
treeSelectionSelectPath sel treePath
col <- treeViewGetColumn treeView 0
treeViewScrollToCell treeView treePath (fromJust col)
(Just (0.3,0.3))
case mbIdName of
Nothing -> return ()
Just symbol -> do
mbFacetTree <- treeStoreGetTreeSave facetStore []
selF <- treeViewGetSelection facetView
case findPathFor symbol mbFacetTree of
Nothing -> sysMessage Normal "no path found"
Just path -> do
treeSelectionSelectPath selF path
col <- treeViewGetColumn facetView 0
treeViewScrollToCell facetView path (fromJust col)
(Just (0.3,0.3))
symbolFromFacetWrapper :: FacetWrapper -> Symbol
symbolFromFacetWrapper (Itself idDescr) = identifierID idDescr
symbolFromFacetWrapper (ConstructorW _ idDescr) = identifierID idDescr
symbolFromFacetWrapper (FieldW _ idDescr) = identifierID idDescr
symbolFromFacetWrapper (MethodW _ idDescr) = identifierID idDescr
symbolFromFacetWrapper (OrphanedData idDescr) = identifierID idDescr
reloadKeepSelection :: IDEAction
reloadKeepSelection = do
mbMod <- getPane
case mbMod of
Nothing -> return ()
Just mods@(IDEModules _ _ treeView treeStore facetView facetStore _ _ _ _)
-> do
mbTreeSelection <- liftIO $ getSelectionTree treeView treeStore
mbFacetSelection <- liftIO $ getSelectionFacet facetView facetStore
sc <- getScope
fillModulesList sc
liftIO $ treeStoreClear facetStore
let mbs = (case mbTreeSelection of
Nothing -> Nothing
Just (_,[]) -> Nothing
Just (_,((md,_):_)) -> Just (modu $ moduleIdMD md),
case mbFacetSelection of
Nothing -> Nothing
Just fw -> Just (symbolFromFacetWrapper fw))
selectNames mbs
treeStoreGetTreeSave :: TreeStore a -> TreePath -> IO (Maybe (Tree a))
treeStoreGetTreeSave treeStore treePath = catch (do
res <- treeStoreGetTree treeStore treePath
return (Just res)) (\ _ -> return Nothing)
findPathFor :: Symbol -> Maybe (Tree FacetWrapper) -> Maybe TreePath
findPathFor symbol (Just (Node _ forest)) =
foldr ( \i mbTreePath -> findPathFor' [i] (forest !! i) mbTreePath)
Nothing [0 .. ((length forest) - 1)]
where
findPathFor' :: TreePath -> Tree FacetWrapper -> Maybe TreePath -> Maybe TreePath
findPathFor' _ node (Just p) = Just p
findPathFor' path (Node wrap sub) Nothing =
if identifierID (facetIdDescr 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 -> [String] -> [Int] -> Maybe [Int]
treePathFromNameArray (Just tree) [] accu = Just (reverse accu)
treePathFromNameArray (Just tree) (h:t) accu =
let names = map (\t -> fst $ rootLabel t) (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
--}
{--
extractSuperclasses :: String -> [String]
extractSuperclasses str =
let parseRes = trace ("now extracting superclasses for " ++ show str)
parse superclassParser "" str
in case parseRes of
Left err -> throwIDE $show err
Right l -> trace ("found " ++ show l) l
lexer = haskell
lexeme = P.lexeme lexer
whiteSpace = P.whiteSpace lexer
symbol = P.symbol lexer
superclassParser :: CharParser () [String]
superclassParser = do
symbol "class"
whiteSpace
try (do
sc <- classDefParser
symbol "=>"
return [sc])
<|> try (do
symbol "("
scs <- sepBy classDefParser (char ',')
symbol ")"
symbol "=>"
return scs)
<|> return []
<?> "superclasses"
classDefParser :: CharParser () String
classDefParser = do
whiteSpace
c <- oneOf['A'..'Z']
cs <- many (alphaNum <|> oneOf "_'.")
many typeVarParser
return (c:cs)
<?> "classDef"
typeVarParser :: CharParser () String
typeVarParser = do
whiteSpace
c <- oneOf['a'..'z']
cs <- many (alphaNum <|> oneOf "_'.")
return (c:cs)
<?> "typeVar"
--}