leksah-0.8: src/IDE/Pane/Modules.hs
{-# OPTIONS_GHC -XDeriveDataTypeable -XMultiParamTypeClasses
-XScopedTypeVariables -XTypeSynonymInstances #-}
-----------------------------------------------------------------------------
--
-- Module : IDE.Pane.Modules
-- Copyright : (c) Juergen Nicklisch-Franken, Hamish Mackenzie
-- License : GNU-GPL
--
-- Maintainer : Juergen Nicklisch-Franken <info@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.Modules (
IDEModules(..)
, ModulesState(..)
--, showInterface
, selectIdentifier
, reloadKeepSelection
, replaySelHistory
, replayScopeHistory
) where
import Graphics.UI.Gtk hiding (get)
import Graphics.UI.Gtk.Gdk.Events
import Data.Maybe
import Control.Monad.Reader
import qualified Data.Map as Map
import Data.Map (Map)
import Data.Tree
import Data.List
import Distribution.Package
import Distribution.Version
import Data.Char (toLower)
import Prelude hiding (catch)
import Data.IORef
import IDE.Core.State
import IDE.Pane.Info
import IDE.Pane.SourceBuffer
import Control.Event hiding (Event)
import Distribution.ModuleName
import Distribution.Text (simpleParse,display)
import Data.Typeable (Typeable(..))
import Control.Exception (SomeException(..),catch)
import IDE.Package (packageConfig,addModuleToPackageDescr,getModuleTemplate,getPackageDescriptionAndPath)
import Distribution.PackageDescription (allBuildInfo,hsSourceDirs)
import System.FilePath ((</>),dropFileName)
import System.Directory (doesFileExist,createDirectoryIfMissing)
import Graphics.UI.Editor.MakeEditor (buildEditor,FieldDescription(..),mkField)
import Graphics.UI.Editor.Parameters (paraMultiSel,Parameter(..),emptyParams,(<<<-),paraName)
import Graphics.UI.Editor.Simple (boolEditor,okCancelFields,staticListEditor,stringEditor)
import Graphics.UI.Editor.Basics (eventPaneName,GUIEventSelector(..))
import qualified System.IO.UTF8 as UTF8 (writeFile)
import IDE.Utils.GUIUtils (stockIdFromType)
import Debug.Trace
import IDE.Metainfo.Provider
(getSystemInfo, getWorkspaceInfo, getPackageInfo)
-- | A modules pane description
--
data IDEModules = IDEModules {
outer :: VBox
, paned :: HPaned
, treeView :: TreeView
, treeStore :: TreeStore (String, [(ModuleDescr,PackageDescr)])
, descrView :: TreeView
, descrStore :: TreeStore Descr
, 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 String) 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 = ([TreePath], [TreePath])
data SelectionState = SelectionState {
moduleS' :: Maybe ModuleName
, facetS' :: Maybe String
, scope' :: Scope
, blacklist' :: Bool}
deriving (Eq,Ord,Show)
instance Pane IDEModules IDEM
where
primPaneName _ = "Modules"
getAddedIndex _ = 0
getTopWidget = castToWidget . outer
paneId b = "*Modules"
--liftIO $ widgetGrabFocus (descrView p)
getModules :: Maybe PanePath -> IDEM IDEModules
getModules Nothing = forceGetPane (Right "*Modules")
getModules (Just pp) = forceGetPane (Left pp)
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 -> liftIO $ do
i <- panedGetPosition (paned p)
mbTreeSelection <- getSelectionTree (treeView m) (treeStore m)
mbFacetSelection <- getSelectionDescr (descrView m) (descrStore m)
let mbs = (case mbTreeSelection of
Nothing -> Nothing
Just (_,[]) -> Nothing
Just (_,((md,_):_)) -> Just (modu $ mdModuleId md),
case mbFacetSelection of
Nothing -> Nothing
Just fw -> Just (dscName fw))
return (Just (ModulesState 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) (SelectionState (fst se) (snd se) scope useBlacklist)
liftIO $ panedSetPosition (paned mod) i
return p
builder pp nb windows = do
packageInfo' <- getPackageInfo
reifyIDE $ \ ideR -> do
let forest = case packageInfo' of
Nothing -> []
Just (GenScopeC fst,GenScopeC snd)
-> subForest (buildModulesTree (fst,snd))
treeStore <- treeStoreNew forest
treeView <- treeViewNew
treeViewSetModel treeView treeStore
--treeViewSetRulesHint treeView True
renderer0 <- cellRendererPixbufNew
set renderer0 [ cellPixbufStockId := "" ]
renderer <- cellRendererTextNew
col <- treeViewColumnNew
treeViewColumnSetTitle col "Modules"
treeViewColumnSetSizing col TreeViewColumnAutosize
treeViewColumnSetResizable col True
treeViewColumnSetReorderable col True
treeViewAppendColumn treeView col
cellLayoutPackStart col renderer0 False
cellLayoutPackStart col renderer True
cellLayoutSetAttributes col renderer treeStore
$ \row -> [ cellText := fst row]
cellLayoutSetAttributes col renderer0 treeStore
$ \row -> [
cellPixbufStockId :=
if null (snd row)
then ""
else if isJust (mdMbSourcePath (fst (head (snd row))))
then "ide_source"
else ""]
renderer2 <- cellRendererTextNew
col2 <- treeViewColumnNew
treeViewColumnSetTitle col2 "Packages"
treeViewColumnSetSizing col2 TreeViewColumnAutosize
treeViewColumnSetResizable col2 True
treeViewColumnSetReorderable col2 True
treeViewAppendColumn treeView col2
cellLayoutPackStart col2 renderer2 True
cellLayoutSetAttributes col2 renderer2 treeStore
$ \row -> [ cellText := (concat . intersperse ", ")
$ map (display . pdPackage . snd) (snd row)]
treeViewSetHeadersVisible treeView True
treeViewSetEnableSearch treeView True
treeViewSetSearchEqualFunc treeView (Just (treeViewSearch treeView treeStore))
-- Facet view
descrView <- treeViewNew
descrStore <- treeStoreNew []
treeViewSetModel descrView descrStore
renderer30 <- cellRendererPixbufNew
renderer31 <- cellRendererPixbufNew
renderer3 <- cellRendererTextNew
col <- treeViewColumnNew
treeViewColumnSetTitle col "Interface"
--treeViewColumnSetSizing col TreeViewColumnAutosize
treeViewAppendColumn descrView col
cellLayoutPackStart col renderer30 False
cellLayoutPackStart col renderer31 False
cellLayoutPackStart col renderer3 True
cellLayoutSetAttributes col renderer3 descrStore
$ \row -> [ cellText := descrTreeText row]
cellLayoutSetAttributes col renderer30 descrStore
$ \row -> [
cellPixbufStockId := stockIdFromType (descrIdType row)]
cellLayoutSetAttributes col renderer31 descrStore
$ \row -> [
cellPixbufStockId := if isReexported row
then "ide_reexported"
else if isJust (dscMbLocation row)
then
if dscExported row
then "ide_source"
else "ide_source_local"
else ""]
treeViewSetHeadersVisible descrView True
treeViewSetEnableSearch descrView True
treeViewSetSearchEqualFunc descrView (Just (descrViewSearch descrView descrStore))
pane' <- hPanedNew
sw <- scrolledWindowNew Nothing Nothing
containerAdd sw treeView
scrolledWindowSetPolicy sw PolicyAutomatic PolicyAutomatic
sw2 <- scrolledWindowNew Nothing Nothing
containerAdd sw2 descrView
scrolledWindowSetPolicy sw2 PolicyAutomatic PolicyAutomatic
panedAdd1 pane' sw
panedAdd2 pane' sw2
(x,y) <- widgetGetSize nb
panedSetPosition pane' (max 200 (x `quot` 2))
box <- hBoxNew True 2
rb1 <- radioButtonNewWithLabel "Package"
rb2 <- radioButtonNewWithLabelFromWidget rb1 "Workspace"
rb3 <- radioButtonNewWithLabelFromWidget rb1 "System"
toggleButtonSetActive rb3 True
cb2 <- checkButtonNewWithLabel "Imports"
cb <- checkButtonNewWithLabel "Blacklist"
boxPackStart box rb1 PackGrow 2
boxPackStart box rb2 PackGrow 2
boxPackStart box rb3 PackGrow 2
boxPackEnd box cb PackNatural 2
boxPackEnd box cb2 PackNatural 2
boxOuter <- vBoxNew False 2
boxPackStart boxOuter box PackNatural 2
boxPackStart boxOuter pane' PackGrow 2
oldState <- liftIO $ newIORef $ SelectionState Nothing Nothing SystemScope False
expanderState <- liftIO $ newIORef emptyExpansion
scopeRef <- newIORef (SystemScope,True)
let modules = IDEModules boxOuter pane' treeView treeStore descrView descrStore
rb1 rb2 rb3 cb2 cb oldState expanderState
cid3 <- treeView `onRowActivated`
(\ treePath _ -> do
treeViewExpandRow treeView treePath False
return ())
cid1 <- treeView `afterFocusIn`
(\_ -> do reflectIDE (makeActive modules) ideR; return True)
cid2 <- descrView `afterFocusIn`
(\_ -> do reflectIDE (makeActive modules) ideR; return True)
treeView `onButtonPress` (treeViewPopup ideR treeStore treeView)
descrView `onButtonPress` (descrViewPopup ideR descrStore descrView)
rb1 `onToggled` (reflectIDE scopeSelection ideR)
rb2 `onToggled` (reflectIDE scopeSelection ideR)
rb3 `onToggled` (reflectIDE scopeSelection ideR)
cb `onToggled` (reflectIDE scopeSelection ideR)
cb2 `onToggled` (reflectIDE scopeSelection ideR)
sel <- treeViewGetSelection treeView
sel `onSelectionChanged` do
fillFacets treeView treeStore descrView descrStore
reflectIDE recordSelHistory ideR
return ()
sel2 <- treeViewGetSelection descrView
sel2 `onSelectionChanged` do
fillInfo descrView descrStore ideR
reflectIDE recordSelHistory ideR
return ()
return (Just modules,[ConnectC cid1,ConnectC cid2, ConnectC cid3])
selectIdentifier :: Descr -> IDEAction
selectIdentifier idDescr = do
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)
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 _)) ->
if Map.member pid psc1
then (True,False)
else if Map.member pid psc2
then (True,True)
else (False, False)
ws = case workspaceScope of
Nothing -> (False,False)
Just (GenScopeC (PackScope wsc1 _), GenScopeC (PackScope wsc2 _)) ->
if Map.member pid wsc1
then (True,False)
else if Map.member pid wsc2
then (True,True)
else (False, False)
selectIdentifier' :: ModuleName -> String -> IDEAction
selectIdentifier' moduleName symbol =
let nameArray = components moduleName
in do
mods <- getModules Nothing
mbTree <- liftIO $ treeStoreGetTreeSave (treeStore mods) []
case treePathFromNameArray mbTree nameArray [] of
Just treePath -> liftIO $ do
treeViewExpandToPath (treeView mods) treePath
sel <- treeViewGetSelection (treeView mods)
treeSelectionSelectPath sel treePath
col <- treeViewGetColumn (treeView mods) 0
treeViewScrollToCell (treeView mods) treePath (fromJust col) (Just (0.3,0.3))
mbFacetTree <- treeStoreGetTreeSave (descrStore mods) []
selF <- treeViewGetSelection (descrView mods)
case findPathFor symbol mbFacetTree of
Nothing -> sysMessage Normal "no path found"
Just path -> do
treeViewExpandToPath (descrView mods) path
treeSelectionSelectPath selF path
col <- treeViewGetColumn (descrView mods) 0
treeViewScrollToCell (descrView mods) path (fromJust col) (Just (0.3,0.3))
bringPaneToFront mods
Nothing -> return ()
findPathFor :: String -> Maybe (Tree Descr) -> Maybe TreePath
findPathFor symbol (Just (Node _ forest)) =
foldr ( \i mbTreePath -> findPathFor' [i] (forest !! i) mbTreePath)
Nothing [0 .. ((length forest) - 1)]
where
findPathFor' :: TreePath -> Tree Descr -> Maybe TreePath -> Maybe TreePath
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 -> [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
treeViewSearch :: TreeView
-> TreeStore (String, [(ModuleDescr,PackageDescr)])
-> 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 (mdModuleId m)
let res = isInfixOf (map toLower string) (map toLower str2)
return res
searchInModSubnodes :: ModTree -> String -> Bool
searchInModSubnodes tree str =
not $ null
$ filter (\ val ->
let cstr = case snd val of
[] -> fst val
(m,_):_ -> show (Present (mdModuleId m))
in isInfixOf (map toLower str) (map toLower cstr))
$ concatMap flatten (subForest tree)
descrViewSearch :: TreeView
-> TreeStore Descr
-> String
-> TreeIter
-> IO Bool
descrViewSearch descrView descrStore string iter = do
path <- treeModelGetPath descrStore iter
val <- treeStoreGetValue descrStore path
tree <- treeStoreGetTree 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 (isInfixOf (map toLower string) (map toLower (descrTreeText val)))
searchInFacetSubnodes :: DescrTree -> String -> Bool
searchInFacetSubnodes tree str =
not $ null
$ filter (\ val ->
isInfixOf (map toLower str) (map toLower (descrTreeText val)))
$ concatMap flatten (subForest tree)
fillFacets :: TreeView
-> TreeStore (String, [(ModuleDescr,PackageDescr)])
-> TreeView
-> TreeStore Descr
-> IO ()
fillFacets treeView treeStore descrView descrStore = do
sel <- getSelectionTree treeView treeStore
case sel of
Just val
-> case snd val of
((mod,package):_)
-> let forest = buildFacetForrest mod in do
emptyModel <- treeStoreNew []
treeViewSetModel descrView emptyModel
treeStoreClear descrStore
mapM_ (\(e,i) -> treeStoreInsertTree descrStore [] i e)
$ zip forest [0 .. length forest]
treeViewSetModel descrView descrStore
treeViewSetEnableSearch descrView True
treeViewSetSearchEqualFunc descrView (Just (descrViewSearch descrView descrStore))
[] -> treeStoreClear descrStore
Nothing
-> treeStoreClear descrStore
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)
getSelectionDescr :: TreeView
-> TreeStore Descr
-> IO (Maybe Descr)
getSelectionDescr 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 Descr
-> IDERef
-> IO ()
fillInfo treeView lst ideR = do
treeSelection <- treeViewGetSelection treeView
paths <- treeSelectionGetSelectedRows treeSelection
case paths of
[] -> return ()
[a] -> do
descr <- treeStoreGetValue lst a
reflectIDE (setInfo descr) ideR
return ()
_ -> return ()
findDescription :: SymbolTable alpha => PackModule -> alpha -> String -> Maybe (String,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 String [Descr]
getEmptyDefaultScope = Map.empty
fillModulesList :: (Scope,Bool) -> IDEAction
fillModulesList (scope,useBlacklist) = do
mods <- getModules Nothing
prefs <- readIDE prefs
case scope of
SystemScope -> do
accessibleInfo' <- getSystemInfo
case accessibleInfo' of
Nothing -> liftIO $ do
treeStoreClear (treeStore mods)
treeStoreInsertTree (treeStore 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 = liftIO $ do
emptyModel <- treeStoreNew []
treeViewSetModel (treeView mods) emptyModel
treeStoreClear (treeStore mods)
mapM_ (\(e,i) -> treeStoreInsertTree (treeStore mods) [] i e)
$ zip li [0 .. length li]
treeViewSetModel (treeView mods) (treeStore mods)
treeViewSetEnableSearch (treeView mods) True
treeViewSetSearchEqualFunc (treeView mods)
(Just (treeViewSearch (treeView mods) (treeStore mods)))
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 -> String
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)
type ModTree = Tree (String, [(ModuleDescr,PackageDescr)])
--
-- | 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 flatPairs = concatMap (\p -> map (\m -> (m,p)) (pdModules p))
(Map.elems localMap ++ Map.elems otherMap)
emptyTree = (Node ("",[]) [])
resultTree = foldl' insertPairsInTree emptyTree flatPairs
in sortTree resultTree
where
insertPairsInTree :: ModTree -> (ModuleDescr,PackageDescr) -> ModTree
insertPairsInTree tree pair =
let nameArray = components $ modu $ mdModuleId $ fst pair
pairedWith = map (\n -> (n,pair)) nameArray
in insertNodesInTree pairedWith tree
insertNodesInTree :: [(String,(ModuleDescr,PackageDescr))] -> ModTree -> ModTree
insertNodesInTree list@[(str2,pair)] (Node (str1,pairs) forest) =
case partition (\ (Node (s,_) _) -> s == str2) forest of
([],_) -> (Node (str1,pairs) (makeNodes list : forest))
([(Node (_,pairsf) l)],rest)
-> (Node (str1,pairs) ((Node (str2,pair : pairsf) l) : rest))
(_,_) -> throwIDE "insertNodesInTree: impossible1"
insertNodesInTree list@((str2,pair):tl) (Node (str1,pairs) forest) =
case partition (\ (Node (s,_) _) -> s == str2) forest of
([],_) -> (Node (str1,pairs) (makeNodes list : forest))
([found],rest) -> (Node (str1,pairs) (insertNodesInTree tl found : rest))
(_,_) -> throwIDE "insertNodesInTree: impossible2"
insertNodesInTree [] t = t
makeNodes :: [(String,(ModuleDescr,PackageDescr))] -> ModTree
makeNodes [(str,pair)] = Node (str,[pair]) []
makeNodes ((str,_):tl) = Node (str,[]) [makeNodes tl]
makeNodes _ = throwIDE "Impossible in makeNodes"
breakAtDots :: [String] -> String -> [String]
breakAtDots res [] = reverse res
breakAtDots res toBreak = let (newRes,newToBreak) = span (\c -> c /= '.') toBreak
in if null newToBreak
then reverse (newRes : res)
else breakAtDots (newRes : res) (tail newToBreak)
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))
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 source"
item1 `onActivateLeaf` do
sel <- getSelectionTree treeView store
case sel of
Just (_,[(m,_)]) -> case mdMbSourcePath m of
Nothing -> return ()
Just fp -> do
reflectIDE (selectSourceBuf fp) ideR
return ()
otherwise -> return ()
sep1 <- separatorMenuItemNew
item2 <- menuItemNewWithLabel "Expand here"
item2 `onActivateLeaf` (expandHere treeView)
item3 <- menuItemNewWithLabel "Collapse here"
item3 `onActivateLeaf` (collapseHere treeView)
item4 <- menuItemNewWithLabel "Expand all"
item4 `onActivateLeaf` (treeViewExpandAll treeView)
item5 <- menuItemNewWithLabel "Collapse all"
item5 `onActivateLeaf` (treeViewCollapseAll treeView)
sep2 <- separatorMenuItemNew
item6 <- menuItemNewWithLabel "Add module"
item6 `onActivateLeaf` (reflectIDE (addModule treeView store) ideR)
mapM_ (menuShellAppend theMenu) [castToMenuItem item1, castToMenuItem sep1, castToMenuItem item2,
castToMenuItem item3, castToMenuItem item4, castToMenuItem item5, castToMenuItem sep2,
castToMenuItem item6{--,item7,item8--}]
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 mdMbSourcePath m of
Nothing -> return ()
Just fp -> do
reflectIDE (selectSourceBuf fp) ideR
return ()
otherwise -> return ()
return True
else return False
treeViewPopup _ _ _ _ = throwIDE "treeViewPopup wrong event type"
descrViewPopup :: IDERef
-> TreeStore Descr
-> TreeView
-> Event
-> IO (Bool)
descrViewPopup ideR store descrView (Button _ click _ _ _ _ button _ _) = do
if button == RightButton
then do
theMenu <- menuNew
item1 <- menuItemNewWithLabel "Go to definition"
item1 `onActivateLeaf` do
sel <- getSelectionDescr descrView store
case sel of
Just descr -> reflectIDE (goToDefinition descr) ideR
otherwise -> sysMessage Normal "Modules>> descrViewPopup: no selection"
item2 <- menuItemNewWithLabel "Insert in buffer"
item2 `onActivateLeaf` do
sel <- getSelectionDescr descrView store
case sel of
Just descr -> reflectIDE (insertInBuffer descr) ideR
otherwise -> sysMessage Normal "Modules>> descrViewPopup: no selection"
mapM_ (menuShellAppend theMenu) [item1, item2]
menuPopup theMenu Nothing
widgetShowAll theMenu
return True
else if button == LeftButton && click == DoubleClick
then do sel <- getSelectionDescr descrView store
case sel of
Just descr -> reflectIDE (goToDefinition descr) ideR
otherwise -> sysMessage Normal "Modules>> descrViewPopup: no selection2"
return True
else do
mbPane :: Maybe IDEInfo <- reflectIDE getPane ideR
when (isJust mbPane) $ bringPaneToFront (fromJust mbPane)
return False
descrViewPopup _ _ _ _ = throwIDE "descrViewPopup wrong event type"
setScope :: (Scope,Bool) -> IDEAction
setScope (sc,bl) = do
mods <- getModules Nothing
case sc of
(PackageScope False) -> liftIO $ do
toggleButtonSetActive (packageScopeB mods) True
widgetSetSensitive (dependsB mods) True
toggleButtonSetActive (dependsB mods) False
(PackageScope True) -> liftIO $ do
toggleButtonSetActive (packageScopeB mods) True
widgetSetSensitive (dependsB mods) True
toggleButtonSetActive (dependsB mods) True
(WorkspaceScope False) -> liftIO $ do
toggleButtonSetActive (workspaceScopeB mods) True
widgetSetSensitive (dependsB mods) True
toggleButtonSetActive (dependsB mods) False
(WorkspaceScope True) -> liftIO $ do
toggleButtonSetActive (workspaceScopeB mods) True
widgetSetSensitive (dependsB mods) True
toggleButtonSetActive (dependsB mods) True
SystemScope -> liftIO $ do
toggleButtonSetActive (systemScopeB mods) True
widgetSetSensitive (dependsB mods) False
liftIO $ toggleButtonSetActive (blacklistB mods) bl
selectScope (sc,bl)
getScope :: IDEM (Scope,Bool)
getScope = do
mods <- getModules Nothing
rb1s <- liftIO $ toggleButtonGetActive (packageScopeB mods)
rb2s <- liftIO $ toggleButtonGetActive (workspaceScopeB mods)
rb3s <- liftIO $ toggleButtonGetActive (systemScopeB mods)
cb1s <- liftIO $ toggleButtonGetActive (dependsB mods)
cbs <- liftIO $ toggleButtonGetActive (blacklistB mods)
let scope = if rb1s
then PackageScope cb1s
else if rb2s
then WorkspaceScope cb1s
else SystemScope
return (scope,cbs)
scopeSelection :: IDEAction
scopeSelection = do
(sc,bl) <- getScope
setScope (sc,bl)
selectScope (sc,bl)
selectScope :: (Scope,Bool) -> IDEAction
selectScope (sc,bl) = do
recordExpanderState
mods <- getModules Nothing
mbTreeSelection <- liftIO $ getSelectionTree (treeView mods) (treeStore mods)
mbDescrSelection <- liftIO $ getSelectionDescr (descrView mods) (descrStore mods)
ts <- liftIO $ treeViewGetSelection (treeView mods)
withoutRecordingDo $ do
liftIO $ treeSelectionUnselectAll ts
fillModulesList (sc,bl)
let mbs = (case mbTreeSelection of
Nothing -> Nothing
Just (_,[]) -> Nothing
Just (_,((md,_):_)) -> Just (modu $ mdModuleId md),
case mbDescrSelection of
Nothing -> Nothing
Just fw -> Just (dscName fw))
selectNames mbs
recordScopeHistory
applyExpanderState
liftIO $ bringPaneToFront mods
selectNames :: (Maybe ModuleName, Maybe String) -> IDEAction
selectNames (mbModuleName, mbIdName) = do
mods <- getModules Nothing
case mbModuleName of
Nothing -> liftIO $ do
sel <- treeViewGetSelection (treeView mods)
treeSelectionUnselectAll sel
selF <- treeViewGetSelection (descrView mods)
treeSelectionUnselectAll selF
Just moduleName ->
let nameArray = components moduleName
in do
mbTree <- liftIO $ treeStoreGetTreeSave (treeStore mods) []
case treePathFromNameArray mbTree nameArray [] of
Nothing -> return ()
Just treePath -> liftIO $ do
treeViewExpandToPath (treeView mods) treePath
sel <- treeViewGetSelection (treeView mods)
treeSelectionSelectPath sel treePath
col <- treeViewGetColumn (treeView mods) 0
treeViewScrollToCell (treeView mods) treePath (fromJust col)
(Just (0.3,0.3))
case mbIdName of
Nothing -> do
selF <- treeViewGetSelection (descrView mods)
treeSelectionUnselectAll selF
Just symbol -> do
mbDescrTree <- treeStoreGetTreeSave (descrStore mods) []
selF <- treeViewGetSelection (descrView mods)
case findPathFor symbol mbDescrTree of
Nothing -> sysMessage Normal "no path found"
Just path -> do
treeSelectionSelectPath selF path
col <- treeViewGetColumn (descrView mods) 0
treeViewScrollToCell (descrView mods) path (fromJust col)
(Just (0.3,0.3))
reloadKeepSelection :: Bool -> IDEAction
reloadKeepSelection isInitial = trace (">>>Info Changed!!! " ++ show isInitial) $ do
mbMod <- getPane
case mbMod of
Nothing -> return ()
Just mods -> do
state <- readIDE currentState
if not $ isStartingOrClosing state
then do
mbTreeSelection <- liftIO $ getSelectionTree (treeView mods) (treeStore mods)
mbDescrSelection <- liftIO $ getSelectionDescr (descrView mods) (descrStore mods)
sc <- getScope
recordExpanderState
fillModulesList sc
liftIO $ treeStoreClear (descrStore mods)
let mbs = (case mbTreeSelection of
Nothing -> Nothing
Just (_,[]) -> Nothing
Just (_,((md,_):_)) -> Just (modu $ mdModuleId md),
case mbDescrSelection of
Nothing -> Nothing
Just fw -> Just (dscName fw))
applyExpanderState
selectNames mbs
else if isInitial == True
then do
SelectionState moduleS' facetS' sc bl <- trace (">>>Info Changed Initial") $
liftIO $ readIORef (oldSelection mods)
setScope (sc,bl)
fillModulesList (sc, bl)
selectNames (moduleS', facetS')
applyExpanderState
else return ()
treeStoreGetTreeSave :: TreeStore a -> TreePath -> IO (Maybe (Tree a))
treeStoreGetTreeSave treeStore treePath = catch (do
res <- treeStoreGetTree treeStore treePath
return (Just res)) (\ (_ :: SomeException) -> return Nothing)
expandHere :: TreeView -> IO ()
expandHere treeView = do
sel <- treeViewGetSelection treeView
paths <- treeSelectionGetSelectedRows sel
case paths of
[] -> return ()
(hd:_) -> treeViewExpandRow treeView hd True >> return ()
collapseHere :: TreeView -> IO ()
collapseHere treeView = do
sel <- treeViewGetSelection treeView
paths <- treeSelectionGetSelectedRows sel
case paths of
[] -> return ()
(hd:_) -> treeViewCollapseRow treeView hd >> return ()
addModule :: TreeView -> TreeStore (String, [(ModuleDescr,PackageDescr)]) -> IDEAction
addModule treeView store = do
sel <- liftIO $ treeViewGetSelection treeView
paths <- liftIO $ treeSelectionGetSelectedRows sel
categories <- case paths of
[] -> return []
(treePath:_) -> liftIO $ mapM (treeStoreGetValue store)
$ map (\n -> take n treePath) [1 .. length treePath]
mbPD <- getPackageDescriptionAndPath
case mbPD of
Nothing -> ideMessage Normal "No package description"
Just (pd,cabalPath) -> let srcPaths = nub $ concatMap hsSourceDirs $ allBuildInfo pd
rootPath = dropFileName cabalPath
modPath = foldr (\a b -> a ++ "." ++ b) ""
(map fst categories)
in do
window' <- getMainWindow
mbResp <- liftIO $ addModuleDialog window' modPath srcPaths
case mbResp of
Nothing -> return ()
Just (AddModule modPath srcPath isExposed) ->
case simpleParse modPath of
Nothing -> ideMessage Normal ("Not a valid module name :" ++ modPath)
Just moduleName -> do
let target = srcPath </> toFilePath moduleName ++ ".hs"
liftIO $ createDirectoryIfMissing True (dropFileName target)
alreadyExists <- liftIO $ doesFileExist target
if alreadyExists
then ideMessage Normal "File already exists"
else do
template <- liftIO $ getModuleTemplate pd modPath
liftIO $ UTF8.writeFile target template
addModuleToPackageDescr moduleName isExposed
packageConfig
fileOpenThis target
-- Yet another stupid little dialog
data AddModule = AddModule {moduleName :: String, sourceRoot :: FilePath, isExposed :: Bool}
addModuleDialog :: Window -> String -> [String] -> IO (Maybe AddModule)
addModuleDialog parent modString sourceRoots = do
dia <- dialogNew
windowSetTransientFor dia parent
windowSetTitle dia "Construct new module"
upper <- dialogGetUpper dia
lower <- dialogGetActionArea dia
(widget,inj,ext,_) <- buildEditor (moduleFields sourceRoots)
(AddModule modString (head sourceRoots) False)
(widget2,_,_,notifier) <- buildEditor okCancelFields ()
registerEvent notifier Clicked (Left (\e -> do
case eventPaneName e of
"Ok" -> dialogResponse dia ResponseOk
_ -> dialogResponse dia ResponseCancel
return e))
boxPackStart upper widget PackGrow 7
boxPackStart lower widget2 PackNatural 7
widgetShowAll dia
resp <- dialogRun dia
value <- ext (AddModule modString (head sourceRoots) False)
widgetDestroy dia
--find
case resp of
ResponseOk -> return value
_ -> return Nothing
moduleFields :: [FilePath] -> FieldDescription AddModule
moduleFields list = VFD emptyParams [
mkField
(paraName <<<- ParaName ("New module ")
$ emptyParams)
moduleName
(\ a b -> b{moduleName = a})
(stringEditor (\s -> True)),
mkField
(paraName <<<- ParaName ("Root of the source path")
$ paraMultiSel <<<- ParaMultiSel False
$ emptyParams)
(\a -> sourceRoot a)
(\ a b -> b{sourceRoot = a})
(staticListEditor list id),
mkField
(paraName <<<- ParaName ("Is this an exposed library module")
$ emptyParams)
isExposed
(\ a b -> b{isExposed = a})
boolEditor]
-- * Expander State
emptyExpansion = ExpanderState ([],[]) ([],[]) ([],[]) ([],[]) ([],[]) ([],[]) ([],[]) ([],[]) ([],[]) ([],[])
recordExpanderState :: IDEAction
recordExpanderState = do
m <- getModules Nothing
liftIO $ do
oldSel <- readIORef (oldSelection m)
let (sc,bl) = (scope' oldSel, blacklist' oldSel)
paths1 <- getExpandedRows (treeView m) (treeStore 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 -> TreeStore alpha -> IO [TreePath]
getExpandedRows view store = do
mbIter <- treeModelGetIterFirst store
case mbIter of
Nothing -> return []
Just iter -> expandedFor iter []
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 iter
case mbIter of
Nothing -> return (path : accu)
Just iter -> expandedFor iter (path : accu)
else return accu
next <- treeModelIterNext store iter
case next of
Nothing -> return res
Just iter -> expandedFor iter res
applyExpanderState :: IDEAction
applyExpanderState = do
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 -> treeViewExpandToPath (treeView m) p) paths1
mapM_ (\p -> treeViewExpandToPath (descrView m) p) paths2
-- * GUI History
recordSelHistory :: IDEAction
recordSelHistory = do
mods <- getModules Nothing
ideR <- ask
selTree <- liftIO $ getSelectionTree (treeView mods) (treeStore mods)
selDescr <- liftIO $ getSelectionDescr (descrView mods) (descrStore mods)
let selMod = case selTree of
Nothing -> Nothing
Just (_,[]) -> Nothing
Just (_,((md,_):_)) -> Just (modu $ mdModuleId md)
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 String -> IDEAction
replaySelHistory mbModName mbFacetName = do
mods <- getModules Nothing
selectNames (mbModName, mbFacetName)
oldSel <- liftIO $ readIORef (oldSelection mods)
liftIO $ writeIORef (oldSelection mods)
(oldSel{moduleS'= mbModName, facetS' = mbFacetName})
recordScopeHistory :: IDEAction
recordScopeHistory = do
(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
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})