leksah-0.4.2: src/IDE/Pane/Modules.hs
{-# OPTIONS_GHC -XDeriveDataTypeable -XMultiParamTypeClasses
-XScopedTypeVariables -XTypeSynonymInstances #-}
-----------------------------------------------------------------------------
--
-- Module : IDE.Pane.Modules
-- Copyright : (c) Juergen Nicklisch-Franken (aka Jutaro)
-- License : GNU-GPL
--
-- Maintainer : Juergen Nicklisch-Franken <info@leksah.org>
-- Stability : experimental
-- Portability : portable
--
-- | The pane of ide where modules are presented in tree form with their
-- packages and exports
--
-------------------------------------------------------------------------------
module IDE.Pane.Modules (
IDEModules(..)
, ModulesState(..)
, showModules
, 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.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 MyMissing (forceHead)
import IDE.Metainfo.Provider (rebuildActiveInfo)
import qualified System.IO.UTF8 as UTF8 (writeFile)
-- | A modules pane description
--
data IDEModules = IDEModules {
outer :: VBox
, paned :: HPaned
, treeView :: TreeView
, treeStore :: TreeStore (String, [(ModuleDescr,PackageDescr)])
, descrView :: TreeView
, descrStore :: TreeStore Descr
, localScopeB :: RadioButton
, packageScopeB :: RadioButton
, systemScopeB :: RadioButton
, blacklistB :: CheckButton
, oldSelection :: IORef SelectionState
, expanderState :: IORef ExpanderState
} deriving Typeable
data ModulesState = ModulesState Int (Scope,Bool)
(Maybe ModuleName, Maybe Symbol) ExpanderState
deriving(Eq,Ord,Read,Show,Typeable)
data ExpanderState = ExpanderState {
localExp :: ExpanderFacet
, localExpNoBlack :: ExpanderFacet
, packageExp :: ExpanderFacet
, packageExpNoBlack :: 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 IDEObject IDEModules
instance Pane IDEModules IDEM
where
primPaneName _ = "Modules"
getAddedIndex _ = 0
getTopWidget = castToWidget . outer
paneId b = "*Modules"
makeActive p = do
activatePane p []
--liftIO $ widgetGrabFocus (descrView p)
close = closePane
instance RecoverablePane IDEModules ModulesState IDEM where
saveState p = do
m <- getModules
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 $ moduleIdMD md),
case mbFacetSelection of
Nothing -> Nothing
Just fw -> Just (descrName fw))
return (Just (ModulesState i sc mbs expander))
recoverState pp (ModulesState i sc@(scope,useBlacklist) se exp) = do
nb <- getNotebook pp
initModules pp nb
mod <- getModules
liftIO $ writeIORef (expanderState mod) exp
case scope of
Local -> liftIO $ toggleButtonSetActive (localScopeB mod) True
Package -> liftIO $ toggleButtonSetActive (packageScopeB mod) True
System -> liftIO $ toggleButtonSetActive (systemScopeB mod) True
liftIO $ toggleButtonSetActive (blacklistB mod) useBlacklist
liftIO $ panedSetPosition (paned mod) i
fillModulesList sc
selectNames se
applyExpanderState
selectIdentifier :: Descr -> IDEAction
selectIdentifier idDescr = do
accessibleInfo' <- readIDE accessibleInfo
currentInfo' <- readIDE currentInfo
currentScope <- getScope
let pid = pack (descrModu idDescr)
let mbNeededScope = case currentInfo' of
Just (localScope,packageScope) ->
if Map.member pid (fst localScope)
then Just Local
else if Map.member pid (fst packageScope)
then Just Package
else case accessibleInfo' of
Just worldScope ->
if Map.member pid (fst worldScope)
then Just System
else Nothing
Nothing -> Nothing
Nothing -> case accessibleInfo' of
Just worldScope ->
if Map.member pid (fst worldScope)
then Just System
else Nothing
Nothing -> Nothing
case mbNeededScope of
Nothing -> return ()
Just sc -> do
when (fst currentScope < sc) (setScope (sc,snd currentScope))
selectIdentifier' (modu $ descrModu idDescr) (descrName idDescr)
selectIdentifier' :: ModuleName -> Symbol -> IDEAction
selectIdentifier' moduleName symbol =
let nameArray = components moduleName
in do
mods <- getModules
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 :: Symbol -> 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 descrName 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
showModules :: IDEAction
showModules = do
m <- getModules
liftIO $ bringPaneToFront m
liftIO $ widgetGrabFocus (treeView m)
showInterface :: IDEAction
showInterface = do
m <- getModules
liftIO $ bringPaneToFront m
liftIO $ widgetGrabFocus (descrView m)
getModules :: IDEM IDEModules
getModules = do
mbMod <- getPane
case mbMod of
Nothing -> do
prefs <- readIDE prefs
layout <- readIDE layout
let pp = getStandardPanePath (modulesPanePath prefs) layout
nb <- getNotebook pp
initModules pp nb
mbMod <- getPane
case mbMod of
Nothing -> throwIDE "Can't init modules"
Just m -> return m
Just m -> return m
initModules :: PanePath -> Notebook -> IDEAction
initModules panePath nb = do
panes <- readIDE panes
paneMap <- readIDE paneMap
prefs <- readIDE prefs
currentInfo <- readIDE currentInfo
(buf,cids) <- reifyIDE $ \ideR -> do
-- Modules List
let forest = case currentInfo of
Nothing -> []
Just pair -> subForest (buildModulesTree pair)
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 (mbSourcePathMD (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 . packagePD . 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 (mbLocation row)
then "ide_source"
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' (x `quot` 2)
box <- hBoxNew True 2
rb1 <- radioButtonNewWithLabel "Local"
rb2 <- radioButtonNewWithLabelFromWidget rb1 "Package"
rb3 <- radioButtonNewWithLabelFromWidget rb1 "System"
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
oldState <- liftIO $ newIORef $ SelectionState Nothing Nothing System False
expanderState <- liftIO $ newIORef emptyExpansion
scopeRef <- newIORef (System,True)
let modules = IDEModules boxOuter pane' treeView treeStore descrView descrStore
rb1 rb2 rb3 cb oldState expanderState
notebookInsertOrdered nb boxOuter (paneName modules) Nothing
widgetShowAll boxOuter
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)
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 (modules,[ConnectC cid1,ConnectC cid2, ConnectC cid3])
addPaneAdmin buf cids panePath
liftIO $widgetGrabFocus (paned buf)
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 (moduleIdMD 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 (moduleIdMD 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 :: PackModule -> SymbolTable -> Symbol -> Maybe (Symbol,Descr)
findDescription md st s =
case Map.lookup s st of
Nothing -> Nothing
Just l -> case filter (\id -> md == descrModu id) l of
[] -> Nothing
l -> Just (s,head l)
fillModulesList :: (Scope,Bool) -> IDEAction
fillModulesList (scope,useBlacklist) = do
mods <- getModules
prefs <- readIDE prefs
currentInfo' <- readIDE currentInfo
accessibleInfo' <- readIDE accessibleInfo
case currentInfo' of
Nothing -> case (scope,accessibleInfo') of
(System,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 mods)
mapM_ (\(e,i) -> treeStoreInsertTree (treeStore mods) [] i e)
$ zip li [0 .. length li]
_ -> liftIO $ do
treeStoreClear (treeStore mods)
treeStoreInsertTree (treeStore mods) [] 0 (Node ("",[]) [])
Just (l,p) -> let (l',p'@(pm,ps)) = case scope of
Local -> (l,(Map.empty,Map.empty))
Package -> (l,p)
System -> 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 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 = packagePD 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 (Descr id _ _ _ _ (InstanceDescr binds)) = id ++ " " ++ printBinds binds
where
printBinds [] = ""
printBinds (a:[]) = a
printBinds (a:b) = a ++ " " ++ printBinds b
descrTreeText d = descrName d
descrIdType :: Descr -> DescrType
descrIdType = descrType . details
buildFacetForrest :: ModuleDescr -> DescrForest
buildFacetForrest modDescr =
let (instances,other) = partition (\id -> case details id of
InstanceDescr _ -> True
_ -> False)
$ take 2000 $ idDescriptionsMD 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 details descr of
DataDescr constructors fields ->
Node descr ((map (\(fn,ty) -> Node (makeReexported descr (Descr{descrName' = fn, typeInfo' = ty,
descrModu' = descrModu descr, mbLocation' = mbLocation descr,
mbComment' = mbComment descr, details' = ConstructorDescr {typeDescrC = descr}})) [])
constructors)
++ (map (\(fn,ty) -> Node (makeReexported descr (Descr{descrName' = fn, typeInfo' = ty,
descrModu' = descrModu descr, mbLocation' = mbLocation descr,
mbComment' = mbComment descr, details' = FieldDescr {typeDescrF = descr}})) [])
fields))
NewtypeDescr constr mbField ->
Node descr (Node (makeReexported descr (Descr{descrName' = fst constr, typeInfo' = snd constr,
descrModu' = descrModu descr, mbLocation' = mbLocation descr,
mbComment' = mbComment descr, details' = ConstructorDescr {typeDescrC = descr}})) []
: case mbField of
Just fld ->
[Node (makeReexported descr (Descr{descrName' = fst fld, typeInfo' = snd fld,
descrModu' = descrModu descr, mbLocation' = mbLocation descr,
mbComment' = mbComment descr, details' = FieldDescr {typeDescrF = descr}})) []]
Nothing -> [])
ClassDescr _ methods ->
Node descr (map (\(fn,ty) -> Node (makeReexported descr (Descr{descrName' = fn, typeInfo' = ty,
descrModu' = descrModu descr, mbLocation' = mbLocation descr,
mbComment' = mbComment descr, details' = MethodDescr {classDescrM = descr}})) [])
methods)
_ -> Node descr []
where
makeReexported :: Descr -> Descr -> Descr
makeReexported d1 d2
| isReexported d1 = Reexported{descrModu' = descrModu' d1, impDescr = d2}
| otherwise = d2
addInstances :: (DescrForest,[Descr])
-> Descr
-> (DescrForest,[Descr])
addInstances (forest,orphaned) instDescr =
case foldl' (matches instDescr) ([],False) forest of
(f,True) -> (f,orphaned)
(f,False) -> (forest, instDescr:orphaned)
matches :: Descr
-> (DescrForest,Bool)
-> DescrTree
-> (DescrForest,Bool)
matches instDescr (forest,False) (Node dd@(Descr id _ _ _ _ (DataDescr _ _)) sub)
| not (null (binds (details instDescr))) &&
id == head (binds (details instDescr))
= ((Node dd (sub ++ [Node newInstDescr []])):forest,True)
where newInstDescr = if isNothing (mbLocation instDescr)
then instDescr{mbLocation' = mbLocation dd}
else instDescr
matches instDescr (forest,False) (Node dd@(Descr id _ _ _ _ (NewtypeDescr _ _)) sub)
| not (null (binds (details instDescr))) &&
id == head (binds (details instDescr))
= ((Node dd (sub ++ [Node newInstDescr []])):forest,True)
where newInstDescr = if isNothing (mbLocation instDescr)
then instDescr{mbLocation' = mbLocation dd}
else instDescr
matches _ (forest,b) node = (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 :: (PackageScope,PackageScope) -> ModTree
buildModulesTree ((localMap,_),(otherMap,_)) =
let flatPairs = concatMap (\p -> map (\m -> (m,p)) (exposedModulesPD 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 $ moduleIdMD $ 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 mbSourcePathMD 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 mbSourcePathMD 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"
menuShellAppend theMenu item1
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
case sc of
Local -> liftIO $ toggleButtonSetActive (localScopeB mods) True
Package -> liftIO $ toggleButtonSetActive (packageScopeB mods) True
System -> liftIO $ toggleButtonSetActive (systemScopeB mods) True
liftIO $ toggleButtonSetActive (blacklistB mods) bl
selectScope (sc,bl)
getScope :: IDEM (Scope,Bool)
getScope = do
mods <- getModules
rb1s <- liftIO $ toggleButtonGetActive (localScopeB mods)
rb2s <- liftIO $ toggleButtonGetActive (packageScopeB mods)
rb3s <- liftIO $ toggleButtonGetActive (systemScopeB mods)
cbs <- liftIO $ toggleButtonGetActive (blacklistB mods)
let scope = if rb1s
then Local
else if rb2s
then Package
else System
return (scope,cbs)
scopeSelection :: IDEAction
scopeSelection = do
(sc,bl) <- getScope
selectScope (sc,bl)
selectScope :: (Scope,Bool) -> IDEAction
selectScope (sc,bl) = do
recordExpanderState
mods <- getModules
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 $ moduleIdMD md),
case mbDescrSelection of
Nothing -> Nothing
Just fw -> Just (descrName fw))
selectNames mbs
recordScopeHistory
applyExpanderState
liftIO $ bringPaneToFront mods
selectNames :: (Maybe ModuleName, Maybe Symbol) -> IDEAction
selectNames (mbModuleName, mbIdName) = do
mods <- getModules
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 :: IDEAction
reloadKeepSelection = do
mbMod <- getPane
case mbMod of
Nothing -> return ()
Just mods
-> 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 $ moduleIdMD md),
case mbDescrSelection of
Nothing -> Nothing
Just fw -> Just (descrName fw))
applyExpanderState
selectNames mbs
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 = concatMap hsSourceDirs $ allBuildInfo pd
rootPath = dropFileName cabalPath
modPath = foldr (\a b -> a ++ "." ++ b) ""
(map fst categories)
in do
mbResp <- liftIO $ addModuleDialog 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
rebuildActiveInfo
fileOpenThis target
-- Yet another stupid little dialog
data AddModule = AddModule {moduleName :: String, sourceRoot :: FilePath, isExposed :: Bool}
addModuleDialog :: String -> [String] -> IO (Maybe AddModule)
addModuleDialog modString sourceRoots = do
dia <- dialogNew
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 = forceHead a "Modules>>moduleFields"})
(staticListEditor list),
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
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
(Local,True) -> es{localExp = (paths1,paths2)}
(Local,False) -> es{localExpNoBlack = (paths1,paths2)}
(Package,True) -> es{packageExp = (paths1,paths2)}
(Package,False) -> es{packageExpNoBlack = (paths1,paths2)}
(System,True) -> es{systemExp = (paths1,paths2)}
(System,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
(sc,bl) <- getScope
liftIO $ do
es <- readIORef (expanderState m)
let (paths1,paths2) = case (sc,bl) of
(Local,True) -> localExp es
(Local,False) -> localExpNoBlack es
(Package,True) -> packageExp es
(Package,False) -> packageExpNoBlack es
(System,True) -> systemExp es
(System,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
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 $ moduleIdMD md)
let selFacet = case selDescr of
Nothing -> Nothing
Just descr -> Just (descrName descr)
oldSel <- liftIO $ readIORef (oldSelection mods)
triggerEvent ideR (RecordHistory ((ModuleSelected selMod selFacet),
(ModuleSelected (moduleS' oldSel) (facetS' oldSel))))
liftIO $ writeIORef (oldSelection mods) (oldSel{moduleS'= selMod, facetS' = selFacet})
return ()
replaySelHistory :: Maybe ModuleName -> Maybe Symbol -> IDEAction
replaySelHistory mbModName mbFacetName = do
mods <- getModules
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
oldSel <- liftIO $ readIORef (oldSelection mods)
triggerEvent ideR (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
liftIO $ do
toggleButtonSetActive (blacklistB mods) bl
toggleButtonSetActive (localScopeB mods) (sc == Local)
toggleButtonSetActive (packageScopeB mods) (sc == Package)
toggleButtonSetActive (systemScopeB mods) (sc == System)
setScope (sc,bl)
oldSel <- liftIO $ readIORef (oldSelection mods)
liftIO $ writeIORef (oldSelection mods) (oldSel{scope'= sc, blacklist' = bl})