diff --git a/data/Current.session b/data/Current.session --- a/data/Current.session +++ b/data/Current.session @@ -1,5 +1,5 @@ Layout: VerticalP (TerminalP (Just LeftP) (-1)) (HorizontalP (TerminalP (Just BottomP) 0) (TerminalP (Just BottomP) 1) 376) 737 -Population: [(Just (LogSt LogState),[RightP,BottomP]),(Just (ModulesSt (ModulesState 335 (Package,True) (Nothing,Nothing))),[RightP,TopP]),(Just (SearchSt (SearchState {searchString = "", searchScope = System, searchMode = Prefix {caseSense = False}})),[RightP,TopP])] +Population: [(Just (LogSt LogState),[RightP,BottomP]),(Just (ModulesSt (ModulesState 335 (System,True) (Nothing,Nothing) (ExpanderState {localExp = ([],[]), localExpNoBlack = ([],[]), packageExp = ([],[]), packageExpNoBlack = ([],[]), systemExp = ([],[]), systemExpNoBlack = ([],[])}))),[RightP,TopP]),(Just (SearchSt (SearchState {searchString = "", searchScope = System, searchMode = Prefix {caseSense = False}})),[RightP,TopP])] Window size: (1024,780) Active package: Nothing diff --git a/data/Default.menu b/data/Default.menu --- a/data/Default.menu +++ b/data/Default.menu @@ -3,6 +3,7 @@ + @@ -45,6 +46,7 @@ + diff --git a/leksah.cabal b/leksah.cabal --- a/leksah.cabal +++ b/leksah.cabal @@ -1,5 +1,5 @@ name: leksah -version: 0.4.1 +version: 0.4.2 cabal-version: >=1.4 build-type: Custom license: GPL @@ -29,13 +29,12 @@ data/ide_konstructor.png data/ide_make.png data/ide_method.png data/ide_newtype.png data/ide_reexported.png data/ide_other.png data/ide_rule.png data/ide_run.png data/ide_slot.png - data/ide_source.png data/ide_type.png data/leksah.png - Readme LICENSE data/LICENSE - data/Module.template + data/ide_source.png data/ide_type.png data/leksah.png Readme + LICENSE data/LICENSE data/Module.template data-dir: "" extra-source-files: Setup.lhs extra-tmp-files: - + executable: leksah main-is: Main.hs buildable: True @@ -53,21 +52,21 @@ install-includes: include-dirs: hs-source-dirs: src -other-modules: IDE.Metainfo.Serializable Data.Binary.Shared - MyMissing Default Main DeepSeq Graphics.UI.Editor.Simple - Graphics.UI.Editor.Parameters Graphics.UI.Editor.Basics - Graphics.UI.Editor.Composite Graphics.UI.Editor.MakeEditor - Graphics.UI.Frame.Panes Graphics.UI.Frame.ViewFrame Control.Event - IDE.Package IDE.Keymap IDE.PrinterParser IDE.Exception - IDE.SpecialEditors IDE.SaveSession IDE.Leksah IDE.DescriptionPP - IDE.Find IDE.Menu IDE.Completion IDE.FileUtils IDE.SourceCandy - IDE.GUIHistory IDE.NotebookFlipper IDE.Pane.PackageFlags +other-modules: DeepSeq MyMissing Default Control.Event + Graphics.UI.Editor.Basics Graphics.UI.Editor.Composite + Graphics.UI.Editor.Simple Graphics.UI.Editor.Parameters + Graphics.UI.Editor.MakeEditor Graphics.UI.Frame.Panes + Graphics.UI.Frame.ViewFrame Data.Binary.Shared IDE.PrinterParser + IDE.Completion IDE.Exception IDE.ImportTool IDE.SaveSession + IDE.Menu IDE.SpecialEditors IDE.GUIHistory IDE.Leksah IDE.Keymap + IDE.SourceCandy IDE.Package IDE.FileUtils IDE.DescriptionPP + IDE.Find IDE.NotebookFlipper IDE.Metainfo.SourceCollector + IDE.Metainfo.Provider IDE.Metainfo.Serializable + IDE.Metainfo.InterfaceCollector IDE.Metainfo.GHCUtils + IDE.Core.Types IDE.Core.State IDE.Pane.Modules IDE.Pane.References + IDE.Pane.PackageFlags IDE.Pane.PackageEditor IDE.Pane.Search IDE.Pane.Info IDE.Pane.ClassHierarchy IDE.Pane.SourceBuffer - IDE.Pane.Modules IDE.Pane.Preferences IDE.Pane.Log IDE.Pane.Callers - IDE.Pane.Search IDE.Pane.PackageEditor IDE.Metainfo.Provider - IDE.Metainfo.SourceCollector IDE.Metainfo.InterfaceCollector - IDE.Metainfo.GHCUtils IDE.Core.State IDE.Core.Types Data.Binary.Shared - IDE.Metainfo.Serializable + IDE.Pane.Preferences IDE.Pane.Log ghc-prof-options: -prof -auto-all ghc-shared-options: -prof -auto-all ghc-options: -fwarn-unused-imports -fwarn-missing-fields -fwarn-incomplete-patterns diff --git a/src/Graphics/UI/Editor/Composite.hs b/src/Graphics/UI/Editor/Composite.hs --- a/src/Graphics/UI/Editor/Composite.hs +++ b/src/Graphics/UI/Editor/Composite.hs @@ -22,7 +22,6 @@ ) where import Graphics.UI.Gtk -import Graphics.UI.Gtk.ModelView as New import Control.Monad import Data.IORef import Data.Maybe @@ -336,10 +335,10 @@ return event{gtkReturn=True} --- a trivial example: (ColumnDescr False [("",(\row -> [New.cellText := show row]))]) +-- a trivial example: (ColumnDescr False [("",(\row -> [cellText := show row]))]) -- and a nontrivial: --- [("Package",\(Dependency str _) -> [New.cellText := str]) --- ,("Version",\(Dependency _ vers) -> [New.cellText := showVersionRange vers])]) +-- [("Package",\(Dependency str _) -> [cellText := str]) +-- ,("Version",\(Dependency _ vers) -> [cellText := showVersionRange vers])]) data ColumnDescr row = ColumnDescr Bool [(String,(row -> [AttrOp CellRendererText]))] -- @@ -370,57 +369,57 @@ removeButton <- buttonNewWithLabel "Remove" containerAdd buttonBox addButton containerAdd buttonBox removeButton - listStore <- New.listStoreNew ([]:: [alpha]) - list <- New.treeViewNewWithModel listStore + listStore <- listStoreNew ([]:: [alpha]) + list <- treeViewNewWithModel listStore let minSize = getParameter paraMinSize parameters uncurry (widgetSetSizeRequest list) minSize sw <- scrolledWindowNew Nothing Nothing containerAdd sw list scrolledWindowSetPolicy sw PolicyAutomatic PolicyAutomatic - sel <- New.treeViewGetSelection list - New.treeSelectionSetMode sel SelectionSingle + sel <- treeViewGetSelection list + treeSelectionSetMode sel SelectionSingle mapM_ (\(str,func) -> do - col <- New.treeViewColumnNew - New.treeViewColumnSetTitle col str - New.treeViewColumnSetResizable col True - New.treeViewAppendColumn list col - renderer <- New.cellRendererTextNew - New.cellLayoutPackStart col renderer True - New.cellLayoutSetAttributes col renderer listStore func + col <- treeViewColumnNew + treeViewColumnSetTitle col str + treeViewColumnSetResizable col True + treeViewAppendColumn list col + renderer <- cellRendererTextNew + cellLayoutPackStart col renderer True + cellLayoutSetAttributes col renderer listStore func ) columnsDD - New.treeViewSetHeadersVisible list showHeaders - sel `New.onSelectionChanged` selectionHandler sel listStore injS + treeViewSetHeadersVisible list showHeaders + sel `onSelectionChanged` selectionHandler sel listStore injS boxPackStart box sw PackGrow 0 boxPackStart box buttonBox PackNatural 0 boxPackStart box frameS PackNatural 0 activateEvent (castToWidget list) notifier Nothing FocusOut containerAdd widget box - New.listStoreClear listStore - mapM_ (New.listStoreAppend listStore) v + listStoreClear listStore + mapM_ (listStoreAppend listStore) v addButton `onClicked` do mbv <- extS case mbv of Just v -> do - seq <- New.listStoreAppend listStore v - New.treeSelectionSelectPath sel [seq] + seq <- listStoreAppend listStore v + treeSelectionSelectPath sel [seq] mbCol <- treeViewGetColumn list 0 case mbCol of Nothing -> return () - Just col -> New.treeViewScrollToCell list [seq] col Nothing + Just col -> treeViewScrollToCell list [seq] col Nothing return () Nothing -> return () removeButton `onClicked` do - mbi <- New.treeSelectionGetSelected sel + mbi <- treeSelectionGetSelected sel case mbi of Nothing -> return () Just iter -> do - [i] <- New.treeModelGetPath listStore iter - New.listStoreRemove listStore i + [i] <- treeModelGetPath listStore iter + listStoreRemove listStore i writeIORef coreRef (Just listStore) injS getDefault Just listStore -> do - New.listStoreClear listStore - mapM_ (New.listStoreAppend listStore) v) + listStoreClear listStore + mapM_ (listStoreAppend listStore) v) (do core <- readIORef coreRef case core of Nothing -> return Nothing @@ -430,24 +429,24 @@ (paraMinSize <<<- ParaMinSize (-1,-1) $ parameters) notifier where - listStoreGetValues :: New.ListStore a -> IO [a] - listStoreGetValues listStore = New.treeModelGetIterFirst listStore >>= getTail + listStoreGetValues :: ListStore a -> IO [a] + listStoreGetValues listStore = treeModelGetIterFirst listStore >>= getTail where getTail mbi = case mbi of Nothing -> return [] Just iter -> do - [i] <- New.treeModelGetPath listStore iter - v <- New.listStoreGetValue listStore i - mbi2 <- New.treeModelIterNext listStore iter + [i] <- treeModelGetPath listStore iter + v <- listStoreGetValue listStore i + mbi2 <- treeModelIterNext listStore iter rest <- getTail mbi2 return (v : rest) - selectionHandler :: New.TreeSelection -> New.ListStore a -> Injector a -> IO () + selectionHandler :: TreeSelection -> ListStore a -> Injector a -> IO () selectionHandler sel listStore inj = do - ts <- New.treeSelectionGetSelected sel + ts <- treeSelectionGetSelected sel case ts of Nothing -> return () Just iter -> do - [i] <- New.treeModelGetPath listStore iter - v <- New.listStoreGetValue listStore i + [i] <- treeModelGetPath listStore iter + v <- listStoreGetValue listStore i inj v return () diff --git a/src/Graphics/UI/Editor/MakeEditor.hs b/src/Graphics/UI/Editor/MakeEditor.hs --- a/src/Graphics/UI/Editor/MakeEditor.hs +++ b/src/Graphics/UI/Editor/MakeEditor.hs @@ -29,7 +29,6 @@ ) where import Graphics.UI.Gtk -import Graphics.UI.Gtk.ModelView as New import Control.Monad import Data.List(unzip4) @@ -80,22 +79,22 @@ scrolledWindowSetPolicy sw PolicyAutomatic PolicyAutomatic notebookAppendPage nb sw labelString) (zip (map fst pairList) widgets) - listStore <- New.listStoreNew (map fst pairList) - listView <- New.treeViewNewWithModel listStore + listStore <- listStoreNew (map fst pairList) + listView <- treeViewNewWithModel listStore widgetSetSizeRequest listView 100 (-1) - sel <- New.treeViewGetSelection listView - New.treeSelectionSetMode sel SelectionSingle - renderer <- New.cellRendererTextNew - col <- New.treeViewColumnNew - New.treeViewAppendColumn listView col - New.cellLayoutPackStart col renderer True - New.cellLayoutSetAttributes col renderer listStore $ \row -> - [ New.cellText := row ] - New.treeViewSetHeadersVisible listView False - New.treeSelectionSelectPath sel [0] + sel <- treeViewGetSelection listView + treeSelectionSetMode sel SelectionSingle + renderer <- cellRendererTextNew + col <- treeViewColumnNew + treeViewAppendColumn listView col + cellLayoutPackStart col renderer True + cellLayoutSetAttributes col renderer listStore $ \row -> + [ cellText := row ] + treeViewSetHeadersVisible listView False + treeSelectionSelectPath sel [0] notebookSetCurrentPage nb 0 - sel `New.onSelectionChanged` (do - selections <- New.treeSelectionGetSelectedRows sel + sel `onSelectionChanged` (do + selections <- treeSelectionGetSelectedRows sel case selections of [[i]] -> notebookSetCurrentPage nb i _ -> return ()) diff --git a/src/Graphics/UI/Editor/Simple.hs b/src/Graphics/UI/Editor/Simple.hs --- a/src/Graphics/UI/Editor/Simple.hs +++ b/src/Graphics/UI/Editor/Simple.hs @@ -33,7 +33,6 @@ import Graphics.UI.Gtk import qualified Graphics.UI.Gtk as Gtk -import Graphics.UI.Gtk.ModelView as New import IDE.Core.State (MessageLevel(..)) import IDE.Core.State (sysMessage) import Control.Monad @@ -312,28 +311,28 @@ core <- readIORef coreRef case core of Nothing -> do - combo <- New.comboBoxNewText + combo <- comboBoxNewText mapM_ (\o -> comboBoxAppendText combo (show o)) list widgetSetName combo (getParameter paraName parameters) mapM_ (activateEvent (castToWidget combo) notifier Nothing) [FocusOut,FocusIn] - New.comboBoxSetActive combo 1 + comboBoxSetActive combo 1 containerAdd widget combo let ind = elemIndex obj list case ind of - Just i -> New.comboBoxSetActive combo i + Just i -> comboBoxSetActive combo i Nothing -> return () writeIORef coreRef (Just combo) Just combo -> do let ind = elemIndex obj list case ind of - Just i -> New.comboBoxSetActive combo i + Just i -> comboBoxSetActive combo i Nothing -> return ()) (do core <- readIORef coreRef case core of Nothing -> return Nothing Just combo -> do - ind <- New.comboBoxGetActive combo + ind <- comboBoxGetActive combo case ind of (-1) -> return Nothing otherwise -> return (Just (list !! ind))) @@ -351,36 +350,36 @@ core <- readIORef coreRef case core of Nothing -> do - listStore <- New.listStoreNew ([]:: [alpha]) - listView <- New.treeViewNewWithModel listStore + listStore <- listStoreNew ([]:: [alpha]) + listView <- treeViewNewWithModel listStore widgetSetName listView (getParameter paraName parameters) mapM_ (activateEvent (castToWidget listView) notifier Nothing) [FocusOut,FocusIn] - sel <- New.treeViewGetSelection listView - New.treeSelectionSetMode sel SelectionMultiple - renderer <- New.cellRendererTextNew - col <- New.treeViewColumnNew - New.treeViewAppendColumn listView col - New.cellLayoutPackStart col renderer True - New.cellLayoutSetAttributes col renderer listStore - $ \row -> [ New.cellText := show row ] - New.treeViewSetHeadersVisible listView False - New.listStoreClear listStore - mapM_ (New.listStoreAppend listStore) objs + sel <- treeViewGetSelection listView + treeSelectionSetMode sel SelectionMultiple + renderer <- cellRendererTextNew + col <- treeViewColumnNew + treeViewAppendColumn listView col + cellLayoutPackStart col renderer True + cellLayoutSetAttributes col renderer listStore + $ \row -> [ cellText := show row ] + treeViewSetHeadersVisible listView False + listStoreClear listStore + mapM_ (listStoreAppend listStore) objs containerAdd widget listView - New.treeSelectionUnselectAll sel + treeSelectionUnselectAll sel --let inds = catMaybes $map (\obj -> elemIndex obj list) objs - --mapM_ (\i -> New.treeSelectionSelectPath sel [i]) inds + --mapM_ (\i -> treeSelectionSelectPath sel [i]) inds writeIORef coreRef (Just (listView,listStore)) Just (listView,listStore) -> do - New.listStoreClear listStore - mapM_ (New.listStoreAppend listStore) objs) + listStoreClear listStore + mapM_ (listStoreAppend listStore) objs) (do core <- readIORef coreRef case core of Nothing -> return Nothing Just (listView,listStore) -> do - sel <- New.treeViewGetSelection listView - treePath <- New.treeSelectionGetSelectedRows sel + sel <- treeViewGetSelection listView + treePath <- treeSelectionGetSelectedRows sel values <- mapM (\[i] -> listStoreGetValue listStore i) treePath return (Just values)) parameters @@ -398,46 +397,46 @@ core <- readIORef coreRef case core of Nothing -> do - listStore <- New.listStoreNew ([]:: [alpha]) - listView <- New.treeViewNewWithModel listStore + listStore <- listStoreNew ([]:: [alpha]) + listView <- treeViewNewWithModel listStore widgetSetName listView (getParameter paraName parameters) mapM_ (activateEvent (castToWidget listView) notifier Nothing) [FocusOut,FocusIn] - sel <- New.treeViewGetSelection listView - New.treeSelectionSetMode sel + sel <- treeViewGetSelection listView + treeSelectionSetMode sel (case getParameter paraMultiSel parameters of True -> SelectionMultiple False -> SelectionSingle) - renderer <- New.cellRendererTextNew - col <- New.treeViewColumnNew - New.treeViewAppendColumn listView col - New.cellLayoutPackStart col renderer True - New.cellLayoutSetAttributes col renderer listStore - $ \row -> [ New.cellText := show row ] - New.treeViewSetHeadersVisible listView False - New.listStoreClear listStore - mapM_ (New.listStoreAppend listStore) list + renderer <- cellRendererTextNew + col <- treeViewColumnNew + treeViewAppendColumn listView col + cellLayoutPackStart col renderer True + cellLayoutSetAttributes col renderer listStore + $ \row -> [ cellText := show row ] + treeViewSetHeadersVisible listView False + listStoreClear listStore + mapM_ (listStoreAppend listStore) list let minSize = getParameter paraMinSize parameters uncurry (widgetSetSizeRequest listView) minSize sw <- scrolledWindowNew Nothing Nothing containerAdd sw listView scrolledWindowSetPolicy sw PolicyAutomatic PolicyAutomatic containerAdd widget sw - New.treeSelectionUnselectAll sel + treeSelectionUnselectAll sel let inds = catMaybes $map (\obj -> elemIndex obj list) objs - mapM_ (\i -> New.treeSelectionSelectPath sel [i]) inds + mapM_ (\i -> treeSelectionSelectPath sel [i]) inds writeIORef coreRef (Just listView) Just listView -> do - sel <- New.treeViewGetSelection listView - New.treeSelectionUnselectAll sel + sel <- treeViewGetSelection listView + treeSelectionUnselectAll sel let inds = catMaybes $map (\obj -> elemIndex obj list) objs - mapM_ (\i -> New.treeSelectionSelectPath sel [i]) inds) + mapM_ (\i -> treeSelectionSelectPath sel [i]) inds) (do core <- readIORef coreRef case core of Nothing -> return Nothing Just listView -> do - sel <- New.treeViewGetSelection listView - treePath <- New.treeSelectionGetSelectedRows sel + sel <- treeViewGetSelection listView + treePath <- treeSelectionGetSelectedRows sel return (Just (map (\[i] -> list !! i) treePath))) parameters notifier diff --git a/src/Graphics/UI/Frame/Panes.hs b/src/Graphics/UI/Frame/Panes.hs --- a/src/Graphics/UI/Frame/Panes.hs +++ b/src/Graphics/UI/Frame/Panes.hs @@ -59,6 +59,7 @@ -- -- | Description of a window layout +-- Horizontal: top bottom Vertical: left right -- data PaneLayout = HorizontalP PaneLayout PaneLayout Int | VerticalP PaneLayout PaneLayout Int diff --git a/src/IDE/Completion.hs b/src/IDE/Completion.hs --- a/src/IDE/Completion.hs +++ b/src/IDE/Completion.hs @@ -22,7 +22,6 @@ import Control.Concurrent import Graphics.UI.Gtk as Gtk import Graphics.UI.Gtk.SourceView -import Graphics.UI.Gtk.ModelView as New import Graphics.UI.Gtk.Gdk.Events as Gtk import IDE.Core.State import IDE.Metainfo.Provider(getDescription,getCompletionOptions) @@ -60,10 +59,10 @@ scrolledWindow <- scrolledWindowNew Nothing Nothing widgetSetSizeRequest scrolledWindow 300 300 containerAdd paned scrolledWindow - tree <- New.treeViewNew + tree <- treeViewNew containerAdd scrolledWindow tree - store <- New.listStoreNew [] - New.treeViewSetModel tree store + store <- listStoreNew [] + treeViewSetModel tree store font <- case textviewFont prefs of Just str -> do @@ -74,14 +73,14 @@ return f widgetModifyFont tree (Just font) - column <- New.treeViewColumnNew - set column [ New.treeViewColumnSizing := New.TreeViewColumnAutosize ] - New.treeViewAppendColumn tree column - renderer <- New.cellRendererTextNew - New.treeViewColumnPackStart column renderer True - cellLayoutSetAttributes column renderer store (\name -> [ New.cellText := name ]) + column <- treeViewColumnNew + set column [ treeViewColumnSizing := TreeViewColumnAutosize ] + treeViewAppendColumn tree column + renderer <- cellRendererTextNew + treeViewColumnPackStart column renderer True + cellLayoutSetAttributes column renderer store (\name -> [ cellText := name ]) - set tree [New.treeViewHeadersVisible := False] + set tree [treeViewHeadersVisible := False] descriptionView <- sourceViewNew descriptionBuffer <- (get descriptionView textViewBuffer) >>= (return . castToSourceBuffer) @@ -103,11 +102,11 @@ visible <- newIORef False activeView <- newIORef Nothing - treeSelection <- New.treeViewGetSelection tree + treeSelection <- treeViewGetSelection tree treeSelection `onSelectionChanged` (do - New.treeSelectionSelectedForeach treeSelection (\treePath -> (do - rows <- New.treeSelectionGetSelectedRows treeSelection + treeSelectionSelectedForeach treeSelection (\treePath -> (do + rows <- treeSelectionGetSelectedRows treeSelection case rows of [treePath] -> withWord store treePath (\name -> do description <- reflectIDE (getDescription name) ideR @@ -138,10 +137,10 @@ cidPress <- sourceView `onKeyPress` (\event -> do let Key { eventKeyName = name, eventModifier = modifier, eventKeyChar = char } = event - Just model <- New.treeViewGetModel tree - selection <- New.treeViewGetSelection tree - count <- New.treeModelIterNChildren model Nothing - Just column <- New.treeViewGetColumn tree 0 + Just model <- treeViewGetModel tree + selection <- treeViewGetSelection tree + count <- treeModelIterNChildren model Nothing + Just column <- treeViewGetColumn tree 0 case (name, modifier, char) of -- ("space", [Gtk.Control], _) -> (do -- reflectIDE (complete sourceView ) ideR @@ -152,7 +151,7 @@ if visible then (do maybeRow <- getRow tree case maybeRow of - Just row -> New.treeViewRowActivated tree [row] column + Just row -> treeViewRowActivated tree [row] column Nothing -> return () return True ) @@ -164,7 +163,7 @@ maybeRow <- getRow tree case maybeRow of Just row -> (do - New.treeViewRowActivated tree [row] column + treeViewRowActivated tree [row] column return True ) Nothing -> (do @@ -180,10 +179,10 @@ maybeRow <- getRow tree let newRow = maybe 0 (\row -> row + 1) maybeRow when (newRow < count) (do - New.treeSelectionSelectPath selection [newRow] - New.treeViewScrollToCell tree [newRow] column Nothing + treeSelectionSelectPath selection [newRow] + treeViewScrollToCell tree [newRow] column Nothing -- Crazy hack to avoid the horizontal scroll - New.treeViewScrollToCell tree [newRow] column Nothing + treeViewScrollToCell tree [newRow] column Nothing ) return True ) @@ -195,10 +194,10 @@ maybeRow <- getRow tree let newRow = maybe 0 (\row -> row - 1) maybeRow when (newRow >= 0) (do - New.treeSelectionSelectPath selection [newRow] - New.treeViewScrollToCell tree [newRow] column Nothing + treeSelectionSelectPath selection [newRow] + treeViewScrollToCell tree [newRow] column Nothing -- Crazy hack to avoid the horizontal scroll - New.treeViewScrollToCell tree [newRow] column Nothing + treeViewScrollToCell tree [newRow] column Nothing ) return True ) @@ -239,7 +238,7 @@ withWord store treePath f = (do case treePath of [row] -> (do - value <- New.listStoreGetValue store row + value <- listStoreGetValue store row f value ) _ -> return () @@ -259,7 +258,7 @@ updateOptions window tree store sourceView = reifyIDE (\ideR -> do buffer <- textViewGetBuffer sourceView - New.listStoreClear (store :: ListStore String) + listStoreClear (store :: ListStore String) (start, end) <- textBufferGetSelectionBounds buffer isWordEnd <- textIterEndsWord end when isWordEnd (do @@ -297,14 +296,14 @@ moveToWordStart start newWordStart <- textBufferGetText buffer start end True when (isPrefixOf wordStart newWordStart) (do - New.listStoreClear store - forM_ (take 200 (List.filter (isPrefixOf newWordStart) options)) (New.listStoreAppend store) + listStoreClear store + forM_ (take 200 (List.filter (isPrefixOf newWordStart) options)) (listStoreAppend store) Rectangle startx starty width height <- textViewGetIterLocation sourceView start (x, y) <- textViewBufferToWindowCoords sourceView TextWindowWidget (startx, starty+height) drawWindow <- widgetGetDrawWindow sourceView (ox, oy) <- drawWindowGetOrigin drawWindow windowMove window (ox+x) (oy+y) - when ((length options) == 1) $ New.treeViewSetCursor tree [0] Nothing + when ((length options) == 1) $ treeViewSetCursor tree [0] Nothing case options of [] -> reflectIDE cancel ideR -- [(wordStart,_)] -> (cancel completion) getRow @@ -313,12 +312,12 @@ ) getRow tree = do - Just model <- New.treeViewGetModel tree - selection <- New.treeViewGetSelection tree - maybeIter <- New.treeSelectionGetSelected selection + Just model <- treeViewGetModel tree + selection <- treeViewGetSelection tree + maybeIter <- treeSelectionGetSelected selection case maybeIter of Just iter -> (do - [row] <- New.treeModelGetPath model iter + [row] <- treeModelGetPath model iter return $ Just row ) Nothing -> return Nothing diff --git a/src/IDE/Core/State.hs b/src/IDE/Core/State.hs --- a/src/IDE/Core/State.hs +++ b/src/IDE/Core/State.hs @@ -21,6 +21,7 @@ , IDEEditor , IDE(..) , IDEState(..) +, isStartingOrClosing , IDERef , IDEM , IDEAction @@ -59,6 +60,10 @@ , getStatusbarIO , getStatusbarLC +, getRecentFiles +, getRecentPackages +, controlIsPressed + , Session , module IDE.Core.Types @@ -70,6 +75,8 @@ import Graphics.UI.Gtk hiding (get) import Graphics.UI.Gtk.SourceView.SourceView () +import Graphics.UI.Gtk.Gdk.Enums (Modifier(..)) +import qualified Graphics.UI.Gtk.Gdk.Events as G (Event(..)) import Data.Map (Map) import qualified Data.Map as Map import Data.IORef @@ -147,10 +154,10 @@ -- ^ event handling table , currentState :: IDEState , guiHistory :: (Bool,[GUIHistory],Int) -, findbar :: Toolbar -, toolbar :: Maybe Toolbar -, findbarVisible :: Bool -, toolbarVisible :: Bool +, findbar :: (Bool,Maybe (Toolbar,ListStore String)) +, toolbar :: (Bool,Maybe Toolbar) +, recentFiles :: [FilePath] +, recentPackages :: [FilePath] } --deriving Show data IDEState = @@ -160,6 +167,11 @@ | IsFlipping TreeView | IsCompleting Window TreeView (ListStore String) Connections +isStartingOrClosing :: IDEState -> Bool +isStartingOrClosing IsStartingUp = True +isStartingOrClosing IsShuttingDown = True +isStartingOrClosing _ = False + data IDEEvent = CurrentInfo | ActivePack @@ -172,6 +184,7 @@ | SearchMeta String | LoadSession FilePath | SaveSession FilePath + | UpdateRecent -- -- | A mutable reference to the IDE state @@ -190,7 +203,9 @@ getSelector (SearchMeta _) = "SearchMeta" getSelector (LoadSession _) = "LoadSession" getSelector (SaveSession _) = "SaveSession" + getSelector UpdateRecent = "UpdateRecent" + instance EventSource IDERef IDEEvent IDEM String where canTriggerEvent o "CurrentInfo" = True @@ -204,6 +219,7 @@ canTriggerEvent o "SearchMeta" = True canTriggerEvent o "LoadSession" = True canTriggerEvent o "SaveSession" = True + canTriggerEvent o "UpdateRecent" = True canTriggerEvent _ _ = False getHandlers ideRef = do @@ -403,6 +419,18 @@ ui <- getUIAction "ui/menubar/_Session/Forget Session" castToToggleAction liftIO $toggleActionGetActive ui +getMenuItem :: String -> IDEM MenuItem +getMenuItem path = do + uiManager' <- readIDE uiManager + mbWidget <- liftIO $ uiManagerGetWidget uiManager' path + case mbWidget of + Nothing -> throwIDE ("State.hs>>getMenuItem: Can't find ui path " ++ path) + Just widget -> return (castToMenuItem widget) + +getRecentFiles , getRecentPackages :: IDEM MenuItem +getRecentFiles = getMenuItem "ui/menubar/_File/_Recent Files" +getRecentPackages = getMenuItem "ui/menubar/_Package/_Recent Packages" + -- (toolbar) getSBSpecialKeys :: PaneMonad alpha => alpha Statusbar @@ -423,6 +451,8 @@ getStatusbarLC :: PaneMonad alpha => alpha Statusbar getStatusbarLC = widgetGet ["topBox","statusBox","statusBarLineColumn"] castToStatusbar - +controlIsPressed :: G.Event -> Bool +controlIsPressed (G.Button _ _ _ _ _ mods _ _ _) | Control `elem` mods = True +controlIsPressed _ = False diff --git a/src/IDE/Core/Types.hs b/src/IDE/Core/Types.hs --- a/src/IDE/Core/Types.hs +++ b/src/IDE/Core/Types.hs @@ -205,16 +205,16 @@ show (Present pd) = (fromPackageIdentifier . packagePD) pd instance Eq PackageDescr where - (== ) a b = packagePD a == packagePD b + (== ) a b = packagePD a == packagePD b instance Ord PackageDescr where - (<=) a b = packagePD a <= packagePD b + (<=) a b = packagePD a <= packagePD b data ModuleDescr = ModuleDescr { moduleIdMD :: PackModule , mbSourcePathMD :: (Maybe FilePath) , exportedNamesMD :: (Set Symbol) -- unqualified -, usagesMD :: (Map ModuleName (Set Symbol)) -- imports +, referencesMD :: (Map ModuleName (Set Symbol)) -- imports , idDescriptionsMD :: [Descr] } deriving (Show,Typeable) diff --git a/src/IDE/Find.hs b/src/IDE/Find.hs --- a/src/IDE/Find.hs +++ b/src/IDE/Find.hs @@ -8,7 +8,7 @@ -- -- Maintainer : Juergen Nicklisch-Franken -- Stability : experimental --- Portability : portable +-- Portability : portablea -- -- | The toolbar for searching and replacing in a text buffer -- @@ -43,7 +43,7 @@ import IDE.Core.State import IDE.Pane.SourceBuffer -import Data.Char (toUpper) +import Data.Char (toLower,toUpper) data FindState = FindState { entryStr :: String @@ -59,18 +59,19 @@ getFindState :: IDEM FindState getFindState = do - fb <- readIDE findbar + (fb,ls) <- needFindbar liftIO $ do lineNr <- getLineEntry fb >>= (\e -> spinButtonGetValueAsInt (castToSpinButton e)) replaceStr <- getReplaceEntry fb >>= (\e -> entryGetText (castToEntry e)) entryStr <- getFindEntry fb >>= (\e -> entryGetText (castToEntry e)) + entryHist <- listStoreToList ls entireWord <- getEntireWord fb wrapAround <- getWrapAround fb caseSensitive <- getCaseSensitive fb backward <- getBackward fb return FindState{ entryStr = entryStr - , entryHist = [] + , entryHist = entryHist , replaceStr = replaceStr , replaceHist = [] , caseSensitive = caseSensitive @@ -81,11 +82,13 @@ setFindState :: FindState -> IDEAction setFindState fs = do - fb <- readIDE findbar + (fb,ls) <- needFindbar liftIO $ do getLineEntry fb >>= (\e -> spinButtonSetValue (castToSpinButton e) (fromIntegral (lineNr fs))) getReplaceEntry fb >>= (\e -> entrySetText (castToEntry e) (replaceStr fs)) getFindEntry fb >>= (\e -> entrySetText (castToEntry e) (entryStr fs)) + listStoreClear ls + mapM_ (\s -> listStoreAppend ls s) (entryHist fs) setEntireWord fb (entireWord fs) setWrapAround fb (wrapAround fs) setCaseSensitive fb (caseSensitive fs) @@ -94,60 +97,63 @@ hideToolbar :: IDEAction hideToolbar = do - mbtb <- readIDE toolbar + (_,mbtb) <- readIDE toolbar case mbtb of Nothing -> return () Just tb -> do - modifyIDE_ (\ide -> return (ide{toolbarVisible = False})) + modifyIDE_ (\ide -> return (ide{toolbar = (False,snd (toolbar ide))})) liftIO $ widgetHideAll tb showToolbar :: IDEAction showToolbar = do - mbtb <- readIDE toolbar + (_,mbtb) <- readIDE toolbar case mbtb of Nothing -> return () Just tb -> do - modifyIDE_ (\ide -> return (ide{toolbarVisible = True})) + modifyIDE_ (\ide -> return (ide{toolbar = (True,snd (toolbar ide))})) liftIO $ widgetShowAll tb toggleToolbar :: IDEAction toggleToolbar = do - toolBarVisible' <- readIDE toolbarVisible - if toolBarVisible' + toolbar' <- readIDE toolbar + if fst toolbar' then hideToolbar else showToolbar hideFindbar :: IDEAction hideFindbar = do - fb <- readIDE findbar - modifyIDE_ (\ide -> return (ide{findbarVisible = False})) - liftIO $ widgetHideAll fb + (_,mbfb) <- readIDE findbar + modifyIDE_ (\ide -> return (ide{findbar = (False,mbfb)})) + case mbfb of + Nothing -> return () + Just (fb,_) -> liftIO $ widgetHideAll fb showFindbar :: IDEAction showFindbar = do - fb <- readIDE findbar - modifyIDE_ (\ide -> return (ide{findbarVisible = True})) - liftIO $ widgetShowAll fb + (_,mbfb) <- readIDE findbar + modifyIDE_ (\ide -> return (ide{findbar = (True,mbfb)})) + case mbfb of + Nothing -> return () + Just (fb,_) -> liftIO $ widgetShowAll fb focusFindEntry :: IDEAction focusFindEntry = do - fb <- readIDE findbar - findbarVisible' <- readIDE findbarVisible - when findbarVisible' $ liftIO $ do + (fb,_) <- needFindbar + liftIO $ do entry <- getFindEntry fb widgetGrabFocus entry - - toggleFindbar :: IDEAction toggleFindbar = do - findbarVisible' <- readIDE findbarVisible - if findbarVisible' + findbar <- readIDE findbar + if fst findbar then hideFindbar else showFindbar -constructFindReplace :: Toolbar -> IDEM (Toolbar) -constructFindReplace toolbar = reifyIDE $ \ ideR -> do +constructFindReplace :: IDEM Toolbar +constructFindReplace = reifyIDE $ \ ideR -> do + toolbar <- toolbarNew + toolbarSetStyle toolbar ToolbarIcons closeButton <- toolButtonNewFromStock "gtk-close" toolbarInsert toolbar closeButton 0 @@ -222,6 +228,24 @@ widgetSetName entryTool "searchEntryTool" toolbarInsert toolbar entryTool 0 + store <- listStoreNew [] + customStoreSetColumn store (makeColumnIdString 0) id + + completion <- entryCompletionNew + entrySetCompletion entry completion + + set completion [entryCompletionModel := Just store] + cell <- cellRendererTextNew + cellLayoutPackStart completion cell True + cellLayoutSetAttributes completion cell store + (\cd -> [cellText := cd]) + entryCompletionSetMatchFunc completion (matchFunc store) + on completion matchSelected $ \ model iter -> do + txt <- treeModelGetValue model iter (makeColumnIdString 0) + entrySetText entry txt + doSearch toolbar Forward ideR + return True + labelTool <- toolItemNew label <- labelNew (Just "Search: ") containerAdd labelTool label @@ -244,9 +268,9 @@ | eventKeyName k == "Escape" -> do getOut ideR return True - | otherwise -> return True - _ -> return True) - entry `onEntryActivate` getOut ideR + | otherwise -> return False + _ -> return False) + entry `onEntryActivate` (doSearch toolbar Forward ideR) replaceButton `onToolButtonClicked` replace toolbar Forward ideR replaceAllButton `onToolButtonClicked` replaceAll toolbar Forward ideR @@ -279,6 +303,7 @@ set toolbar [ toolbarChildHomogeneous labelTool2 := False ] set toolbar [ toolbarChildHomogeneous labelTool3 := False ] + reflectIDE (modifyIDE_ (\ide -> return ide{findbar = (False,Just (toolbar,store))})) ideR return toolbar where getOut = reflectIDE $ do hideFindbar @@ -305,8 +330,32 @@ else do widgetModifyBase entry StateNormal red widgetModifyText entry StateNormal white + reflectIDE (addToHist search) ideR return () +matchFunc :: ListStore String -> String -> TreeIter -> IO Bool +matchFunc model str iter = do + tp <- treeModelGetPath model iter + r <- case tp of + (i:_) -> do row <- listStoreGetValue model i + return (isPrefixOf (map toLower str) (map toLower row) && length str < length row) + otherwise -> return False + return r + +addToHist :: String -> IDEAction +addToHist str = + if null str + then return () + else do + (_,ls) <- needFindbar + liftIO $ do + entryHist <- listStoreToList ls + when (null (filter (\e -> (str `isPrefixOf` e)) entryHist)) $ do + let newList = take 12 (str : filter (\e -> not (e `isPrefixOf` str)) entryHist) + listStoreClear ls + mapM_ (\s -> listStoreAppend ls s) newList + + replace :: Toolbar -> SearchHint -> IDERef -> IO () replace fb hint ideR = do entry <- getFindEntry fb @@ -407,15 +456,15 @@ editReplace' :: Bool -> Bool -> Bool -> String -> String -> SearchHint -> Bool -> IDEM Bool editReplace' entireWord caseSensitive wrapAround search replace hint mayRepeat = inActiveBufContext' False $ \_ gtkbuf currentBuffer _ -> do - startMark <- liftIO $textBufferGetInsert gtkbuf - iter <- liftIO $textBufferGetIterAtMark gtkbuf startMark - iter2 <- liftIO $textIterCopy iter - liftIO $textIterForwardChars iter2 (length search) - str1 <- liftIO $textIterGetText iter iter2 + startMark <- liftIO $ textBufferGetInsert gtkbuf + iter <- liftIO $ textBufferGetIterAtMark gtkbuf startMark + iter2 <- liftIO $ textIterCopy iter + liftIO $ textIterForwardChars iter2 (length search) + str1 <- liftIO $ textIterGetText iter iter2 if compare str1 search caseSensitive then do - liftIO $textBufferDelete gtkbuf iter iter2 - liftIO $textBufferInsert gtkbuf iter replace + liftIO $ textBufferDelete gtkbuf iter iter2 + liftIO $ textBufferInsert gtkbuf iter replace editFind entireWord caseSensitive wrapAround search "" hint else do r <- editFind entireWord caseSensitive wrapAround search "" hint @@ -438,10 +487,28 @@ white = Color 64000 64000 64000 black = Color 0 0 0 +needFindbar :: IDEM (Toolbar,ListStore String) +needFindbar = do + (_,mbfb) <- readIDE findbar + case mbfb of + Nothing -> throwIDE "Find>>needFindbar: Findbar not initialized" + Just p -> return p + editFindInc :: SearchHint -> IDEAction editFindInc hint = do + ideR <- ask + (fb,_) <- needFindbar + case hint of + Initial -> inActiveBufContext' () $ \_ gtkbuf currentBuffer _ -> liftIO $ do + hasSelection <- textBufferHasSelection gtkbuf + when hasSelection $ do + (i1,i2) <- textBufferGetSelectionBounds gtkbuf + text <- textBufferGetText gtkbuf i1 i2 False + findEntry <- getFindEntry fb + entrySetText (castToEntry findEntry) text + return () + _ -> return () showFindbar - fb <- readIDE findbar reifyIDE $ \ideR -> do entry <- getFindEntry fb widgetGrabFocus entry @@ -453,7 +520,7 @@ editGotoLine :: IDEAction editGotoLine = do showFindbar - fb <- readIDE findbar + (fb,_) <- needFindbar entry <- liftIO $ getLineEntry fb liftIO $ widgetGrabFocus entry diff --git a/src/IDE/ImportTool.hs b/src/IDE/ImportTool.hs new file mode 100644 --- /dev/null +++ b/src/IDE/ImportTool.hs @@ -0,0 +1,380 @@ +----------------------------------------------------------------------------- +-- +-- Module : IDE.ImportTool +-- Copyright : 2007-2009 Jürgen Nicklisch-Franken +-- License : GPL +-- +-- Maintainer : Jutaro +-- Stability : provisional +-- Portability : +-- +-- | Help for constructing import statements +-- +----------------------------------------------------------------------------- + +module IDE.ImportTool ( + addAllImports +, addOneImport +, addImport +, parseNotInScope +) where + + +import IDE.Core.State +import Data.List (sort,nub,nubBy) +import Data.Maybe (isNothing,isJust) +import IDE.Metainfo.Provider (getIdentifierDescr) +import Text.PrettyPrint (render) +import Distribution.Text (disp) +import IDE.Pane.SourceBuffer + (fileSaveBuffer, inActiveBufContext', selectSourceBuf) +import Graphics.UI.Gtk +import IDE.SourceCandy (getCandylessText) +import Text.Parsec.Language (haskellStyle) +import Graphics.UI.Editor.MakeEditor (buildEditor,mkField,FieldDescription(..)) +import Graphics.UI.Editor.Parameters + (paraMinSize, + emptyParams, + Parameter(..), + paraMultiSel, + (<<<-), + paraName) +import Graphics.UI.Editor.Basics (eventPaneName,GUIEventSelector(..)) +import IDE.Metainfo.GHCUtils(parseHeader) +import Outputable (showSDoc,Outputable(..)) +import Data.Maybe (fromJust) +import RdrName (mkRdrUnqual) +import OccName (mkDataOcc,mkVarOcc) +import Module (pprModuleName) +import Distribution.Text (display) +import GHC hiding (ModuleName) +import Text.Parsec +import qualified Text.Parsec.Token as P + (operator, dot, identifier, symbol, whiteSpace, lexeme,makeTokenParser) +import Text.ParserCombinators.Parsec (CharParser(..)) +import Graphics.UI.Editor.Simple (okCancelFields, staticListEditor) +import Control.Event (registerEvent) +import Control.Monad (foldM_) +import Control.Monad.Trans (liftIO) + +-- | Add all imports which gave error messages ... +addAllImports :: IDEAction +addAllImports = do + errors <- readIDE errors + foldM_ addThis (True,[]) + [ y | (x,y) <- + nubBy (\ (p1,_) (p2,_) -> p1 == p2) + $ [(x,y) | (x,y) <- [((parseNotInScope . errDescription) e, e) | e <- errors]], + isJust x] + where + addThis :: (Bool,[Descr]) -> ErrorSpec -> IDEM (Bool,[Descr]) + addThis c@(False,_) _ = return c + addThis c@(True,descrList) errorSpec = addImport errorSpec descrList + +-- | Add import for current error ... +addOneImport :: IDEAction +addOneImport = do + errors' <- readIDE errors + currentErr' <- readIDE currentErr + case currentErr' of + Nothing -> do + ideMessage Normal $ "No error selected" + return () + Just i -> do + if 0 <= i && i < length errors' + then let error = errors' !! i + in addImport error [] >> return () + else error "Log>>addOneImport: Error out of range" + +-- | Add one missing import +-- Returns a boolean, if the process should be stopped in case of multiple addition +-- Returns a list of already added descrs, so that it will not be added two times and can +-- be used for default selection +addImport :: ErrorSpec -> [Descr] -> IDEM (Bool, [Descr]) +addImport error descrList = + case parseNotInScope (errDescription error) of + Nothing -> return (True,descrList) + Just nis -> do + currentInfo' <- readIDE currentInfo + case currentInfo' of + Nothing -> return (False,descrList) + Just ((_,symbolTable1),(_,symbolTable2)) -> + case (getIdentifierDescr (id' nis) symbolTable1 symbolTable2) of + [] -> do + ideMessage Normal $ "Identifier " ++ (id' nis) ++ + " not found in imported packages" + return (True,descrList) + descr : [] -> addImport' nis (filePath error) descr descrList + list -> do + mbDescr <- liftIO $ selectModuleDialog list (id' nis) + (if null descrList + then Nothing + else Just (head descrList)) + case mbDescr of + Nothing -> return (False,descrList) + Just descr -> if elem descr descrList + then return (True, descrList) + else addImport' nis (filePath error) descr descrList + +addImport' :: NotInScopeParseResult -> FilePath -> Descr -> [Descr] -> IDEM (Bool,[Descr]) +addImport' nis filePath descr descrList = do + candy' <- readIDE candy + mbBuf <- selectSourceBuf filePath + let mod = modu (descrModu' descr) + case mbBuf of + Nothing -> return (False, descrList) + Just buf -> do + inActiveBufContext' (False,descrList) $ \ nb gtkbuf idebuf n -> do + ideMessage Normal $ "addImport " ++ show (descrName descr) ++ " from " + ++ (render $ disp $ mod) + text <- liftIO $ do + i1 <- textBufferGetStartIter gtkbuf + i2 <- textBufferGetEndIter gtkbuf + getCandylessText candy' gtkbuf + parseResult <- parseHeader filePath text + case parseResult of + Nothing -> do + ideMessage Normal ("Can't parse module header " ++ filePath) + return (False, descrList) + Just imports -> + case filter qualifyAsImportStatement imports of + [] -> let newLine = showSDoc (ppr newImpDecl) ++ "\n" + lastLoc = foldr max noSrcSpan (map getLoc imports) + mbLineSel = if isGoodSrcSpan lastLoc + then Just (srcSpanEndLine lastLoc) + else figureOutImportLine text + in case mbLineSel of + Nothing -> do + ideMessage Normal "No source location" + return (False,descrList) + Just lineSel -> do + liftIO $ do + i1 <- textBufferGetIterAtLine gtkbuf lineSel + textBufferInsert gtkbuf i1 newLine + fileSaveBuffer False nb gtkbuf idebuf n + return (True,descr : descrList) + l@(impDecl:_) -> + let newImpDecl = addToDecl (unLoc impDecl) + newLine = showSDoc (ppr newImpDecl) ++ "\n" + myLoc = getLoc impDecl + mbLineSel = if isGoodSrcSpan myLoc + then Just (srcSpanStartLine myLoc, + srcSpanEndLine myLoc) + else Nothing + + in case mbLineSel of + Nothing -> do + ideMessage Normal "No source location" + return (False,descrList) + Just (lineStart, lineEnd) -> do + liftIO $ do + i1 <- textBufferGetIterAtLine gtkbuf (lineStart - 1) + i2 <- textBufferGetIterAtLine gtkbuf (lineEnd) + textBufferDelete gtkbuf i1 i2 + textBufferInsert gtkbuf i1 newLine + fileSaveBuffer False nb gtkbuf idebuf n + return (True, descr : descrList) + where + isHiding (Just (_,False)) = True + isHiding _ = False + qualifyAsImportStatement :: LImportDecl alpha -> Bool + qualifyAsImportStatement limpDecl = + let impDecl = unLoc limpDecl in + showSDoc (ppr (ideclName impDecl)) == display (modu (descrModu' descr)) + && ((isNothing (mbQual' nis) && not (ideclQualified impDecl)) || + (isJust (mbQual' nis) && ideclQualified impDecl + && fromJust (mbQual' nis) == qualString impDecl)) + && (isNothing (ideclHiding impDecl) || not (fst (fromJust (ideclHiding impDecl)))) + newImpDecl :: LImportDecl RdrName + newImpDecl = noLoc (ImportDecl + (noLoc (mkModuleName (display (modu (descrModu' descr))))) + Nothing + False + (isJust (mbQual' nis)) + (if isJust (mbQual' nis) + then Just (mkModuleName (fromJust (mbQual' nis))) + else Nothing) + (Just (False, [noLoc (newIE)]))) + addToDecl :: ImportDecl RdrName -> ImportDecl RdrName + addToDecl impDecl = case ideclHiding impDecl of + Just (True,listIE) -> throwIDE "ImportTool>>addToDecl: ImpList is hiding" + Just (False,listIE) -> + impDecl{ideclHiding = Just (False, (noLoc newIE : listIE))} + Nothing -> + impDecl{ideclHiding = Just (False, [noLoc (newIE)])} + + newIE :: IE RdrName + newIE = if isSub' nis + then IEThingAll (mkRdrUnqual (mkDataOcc (getRealId descr (id' nis)))) + else if isOp' nis + then IEVar (mkRdrUnqual (mkVarOcc (id' nis))) + else IEVar (mkRdrUnqual (mkVarOcc (id' nis))) + + +getRealId descr id = if isReexported descr + then getRealId (impDescr descr) id + else getReal (details' descr) + where + getReal (FieldDescr d) = descrName' d + getReal (ConstructorDescr d) = descrName' d + getReal (MethodDescr d) = descrName' d + getReal _ = id + +qualString :: ImportDecl alpha -> String +qualString impDecl = case ideclAs impDecl of + Nothing -> "" + Just modName -> showSDoc (pprModuleName modName) + +-- | A single Haskell @import@ declaration. +{-- +type LImportDecl name = Located (ImportDecl name) +data ImportDecl name + = ImportDecl { + ideclName :: Located ModuleName, -- ^ Module name. + ideclPkgQual :: Maybe FastString, -- ^ Package qualifier. + ideclSource :: Bool, -- ^ True <=> {-# SOURCE #-} import + ideclQualified :: Bool, -- ^ True => qualified + ideclAs :: Maybe ModuleName, -- ^ as Module + ideclHiding :: Maybe (Bool, [LIE name]) -- ^ (True => hiding, names) + } +type LIE name = Located (IE name) + +-- | Imported or exported entity. +data IE name + = IEVar name + | IEThingAbs name -- ^ Class/Type (can't tell) + | IEThingAll name -- ^ Class/Type plus all methods/constructors + | IEThingWith name [name] -- ^ Class/Type plus some methods/constructors + | IEModuleContents ModuleName -- ^ (Export Only) + | IEGroup Int (HsDoc name) -- ^ Doc section heading + | IEDoc (HsDoc name) -- ^ Some documentation + | IEDocNamed String -- ^ Reference to named doc +--} + + +-- | The import data + +data NotInScopeParseResult = NotInScopeParseResult { + mbQual' :: Maybe String + , id' :: String + , isSub' :: Bool + , isOp' :: Bool} + deriving Eq + +-- |* The error line parser + +lexer = P.makeTokenParser haskellStyle +whiteSpace = P.whiteSpace lexer +lexeme = P.lexeme lexer +symbol = P.symbol lexer +identifier = P.identifier lexer +dot = P.dot lexer +operator = P.operator lexer + +parseNotInScope :: String -> (Maybe NotInScopeParseResult) +parseNotInScope str = + case parse scopeParser "" str of + Left e -> Nothing + Right r -> Just r + +scopeParser :: CharParser () NotInScopeParseResult +scopeParser = do + whiteSpace + symbol "Not in scope:" + isSub <- optionMaybe (try (choice [symbol "type constructor or class" + , symbol "data constructor"])) + symbol "`" + mbQual <- optionMaybe (try (do + q <- lexeme conid + dot + return q)) + id <- optionMaybe (try identifier) + case id of + Just id -> return (NotInScopeParseResult mbQual + (take (length id - 1) id) (isJust isSub) False) + Nothing -> do + op <- operator + symbol "'" + return (NotInScopeParseResult mbQual op (isJust isSub) True) + "scopeParser" + +conid = do + c <- upper + cs <- many (alphaNum <|> oneOf "_'") + return (c:cs) + "conid" + + +-- |* Where to insert the first import statement? + +figureOutImportLine :: String -> Maybe Int +figureOutImportLine modSource = + case parse importPosParser "" modSource of + Left e -> Nothing + Right pos -> (Just pos) + +importPosParser :: CharParser () Int +importPosParser = do + whiteSpace + skipHeader + pos <- getPosition + skipMany anyChar + eof + return (max (sourceLine pos - 2) 0) + "importPosParser" + +skipHeader :: CharParser () () +skipHeader =do + try (do + symbol "module" + manyTill anyChar (try (symbol "where")) + return ()) + <|> return () + "skipHeader" + +-- |* The little dialog to choose between possible modules + +moduleFields :: [String] -> String -> FieldDescription String +moduleFields list id = + mkField + (paraName <<<- ParaName ("From which module is " ++ id) + $ paraMultiSel <<<- ParaMultiSel False + $ paraMinSize <<<- ParaMinSize (300,400) + $ emptyParams) + (\ a -> [a]) + (\ [a] b -> a) + (staticListEditor ((nub . sort) list)) + +selectModuleDialog :: [Descr] -> String -> Maybe Descr -> IO (Maybe Descr) +selectModuleDialog list id mbDescr = do + let selectionList = map (render . disp . modu . descrModu') list + let mbSelectedString = case mbDescr of + Nothing -> Nothing + Just descr -> Just ((render . disp . modu . descrModu') descr) + let realSelectionString = case mbSelectedString of + Nothing -> head selectionList + Just str -> if elem str selectionList + then str + else head selectionList + dia <- dialogNew + upper <- dialogGetUpper dia + lower <- dialogGetActionArea dia + (widget,inj,ext,_) <- buildEditor (moduleFields selectionList id) realSelectionString + (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 ([]) + widgetDestroy dia + --find + case (resp,value) of + (ResponseOk,Just v) -> return (Just (head (filter (\e -> (render . disp . modu . descrModu') e == v) + list))) + _ -> return Nothing + diff --git a/src/IDE/Leksah.hs b/src/IDE/Leksah.hs --- a/src/IDE/Leksah.hs +++ b/src/IDE/Leksah.hs @@ -71,7 +71,7 @@ -- data Flag = UninstalledProject String | Collect | Rebuild | Sources | VersionF | DebugF - | SessionN String | NoGUI + | SessionN String | NoGUI | ExtractTars (Maybe String) | Help deriving (Show,Eq) options :: [OptDescr Flag] @@ -90,15 +90,19 @@ , Option ['l'] ["LoadSession"] (ReqArg SessionN "NAME") "Load session" , Option ['n'] ["NoGUI"] (NoArg NoGUI) - "Don't start the leksah GUI"] + "Don't start the leksah GUI" + , Option ['x'] ["Extract"] (OptArg ExtractTars "FILE") + "Extract tars from cabal install directory" + , Option ['h'] ["Help"] (NoArg Help) + "Display command line options"] +header = "Usage: ide [OPTION...] files..." ideOpts :: [String] -> IO ([Flag], [String]) ideOpts argv = case getOpt Permute options argv of (o,n,[] ) -> return (o,n) - (_,_,errs) -> ioError $userError $concat errs ++ usageInfo header options - where header = "Usage: ide [OPTION...] files..." + (_,_,errs) -> ioError $ userError $ concat errs ++ usageInfo header options -- --------------------------------------------------------------------- @@ -119,8 +123,25 @@ else "Current.session" when (elem VersionF o) (sysMessage Normal $ "Leksah an IDE for Haskell, version " ++ showVersion version) + when (elem Help o) + (sysMessage Normal $ "Leksah an IDE for Haskell, version " ++ usageInfo header options) prefsPath <- getConfigFilePathForLoad "Default.prefs" prefs <- readPrefs prefsPath + let extract = filter (\x -> case x of + ExtractTars _ -> True + _ -> False) o + when (not (null extract)) $ case head extract of + ExtractTars (Just path) -> do + dir <- getCurrentDirectory + autoExtractTarFiles path + setCurrentDirectory dir + _ -> do + case autoExtractTars prefs of + Nothing -> return () + Just path -> do + dir <- getCurrentDirectory + autoExtractTarFiles path + setCurrentDirectory dir when (elem Sources o) (do buildSourceForPackageDB prefs sysMessage Normal "rebuild SourceForPackageDB") @@ -137,23 +158,29 @@ $ map (\ (UninstalledProject x) -> x) uninstalled else do collectInstalled' prefs writeAscii version (elem Rebuild o) - when (not (elem NoGUI o) && not (elem VersionF o)) (startGUI sessionFilename prefs) + when (not (elem NoGUI o) && not (elem VersionF o) && not (elem Help o)) + (startGUI sessionFilename prefs) -- --------------------------------------------------------------------- -- | Start the GUI startGUI :: String -> Prefs -> IO () -startGUI sessionFilename prefs = do +startGUI sessionFilename iprefs = do trace "start gui called" $ return () st <- initGUI when rtsSupportsBoundThreads (sysMessage Normal "Linked with -threaded") - timeoutAddFull (yield >> return True) priorityHigh 5 + timeoutAddFull (yield >> return True) priorityHigh 25 mapM_ (sysMessage Normal) st uiManager <- uiManagerNew newIcons hasConfigDir' <- hasConfigDir - when (not hasConfigDir') $ firstStart prefs + prefs <- if hasConfigDir' + then return iprefs + else do + firstStart iprefs + prefsPath <- getConfigFilePathForLoad "Default.prefs" + readPrefs prefsPath keysPath <- getConfigFilePathForLoad $ keymapName prefs ++ ".keymap" keyMap <- parseKeymap keysPath let accelActions = setKeymap (keyMap :: KeymapI) actions @@ -169,8 +196,6 @@ iconExists <- doesFileExist iconPath when iconExists $ windowSetIconFromFile win iconPath - findBar <- liftIO $ toolbarNew - toolbarSetStyle findBar ToolbarIcons let ide = IDE { window = win , uiManager = uiManager @@ -191,20 +216,20 @@ , handlers = Map.empty , currentState = IsStartingUp , guiHistory = (False,[],-1) - , findbar = findBar - , toolbar = Nothing - , findbarVisible = True - , toolbarVisible = True + , findbar = (False,Nothing) + , toolbar = (True,Nothing) + , recentFiles = [] + , recentPackages = [] } ideR <- newIORef ide menuDescription' <- menuDescription (acc,menus) <- reflectIDE (makeMenu uiManager accelActions menuDescription') ideR when (length menus /= 2) $ throwIDE ("Failed to build menu" ++ show (length menus)) let toolbar = castToToolbar (menus !! 1) - reflectIDE (do - constructFindReplace findBar - modifyIDE_ (\ide -> return ide{toolbar = Just toolbar}) - initInfo :: IDEAction) ideR + findbar <- reflectIDE (do + initInfo :: IDEAction + modifyIDE_ (\ide -> return (ide{toolbar = (True,Just toolbar)})) + constructFindReplace ) ideR sep0 <- separatorToolItemNew separatorToolItemSetDraw sep0 False toolItemSetExpand sep0 True @@ -225,7 +250,7 @@ boxPackStart vb (menus !! 0) PackNatural 0 boxPackStart vb (menus !! 1) PackNatural 0 boxPackStart vb nb PackGrow 0 - boxPackStart vb findBar PackNatural 0 + boxPackStart vb findbar PackNatural 0 boxPackEnd vb statusBar PackNatural 0 win `onDelete` (\ _ -> do reflectIDE quit ideR; return True) win `onKeyPress` (\ e -> reflectIDE (handleSpecialKeystrokes e) ideR) @@ -238,24 +263,26 @@ registerEvents menus recoverSession sessionPath ) ideR + widgetShowAll win reflectIDE (do + ask >>= \ideR -> triggerEvent ideR UpdateRecent if tbv then showToolbar else hideToolbar if fbv then showFindbar else hideFindbar) ideR - widgetShowAll win --- patch for windows - buffers <- reflectIDE allBuffers ideR - fdesc <- fontDescriptionFromString (case textviewFont prefs of Just str -> str; Nothing -> "") - fds <- fontDescriptionGetSize fdesc - when (isJust fds) $ do - fontDescriptionSetSize fdesc (fromJust fds + 0.01) - mapM_ (\buf -> widgetModifyFont (castToWidget $sourceView buf) (Just fdesc)) buffers + +-- TODO: patch for windows, maybe we can remove it again +-- buffers <- reflectIDE allBuffers ideR +-- fdesc <- fontDescriptionFromString (case textviewFont prefs of Just str -> str; Nothing -> "") +-- fds <- fontDescriptionGetSize fdesc +-- when (isJust fds) $ do +-- fontDescriptionSetSize fdesc (fromJust fds + 0.01) +-- mapM_ (\buf -> widgetModifyFont (castToWidget $sourceView buf) (Just fdesc)) buffers -- end patch - reflectIDE (modifyIDE_ (\ide -> return ide{currentState = IsRunning})) ideR - mainGUI + reflectIDE (modifyIDE_ (\ide -> return ide{currentState = IsRunning})) ideR + mainGUI -- -- | Callback function for onKeyPress of the main window, so 'preprocess' any key @@ -329,8 +356,10 @@ registerEvent stRef "SearchMeta" (Left smHandler) registerEvent stRef "LoadSession" (Left lsHandler) registerEvent stRef "SaveSession" (Left ssHandler) + registerEvent stRef "UpdateRecent" (Left urHandler) + return () where logHandler e@(LogMessage s t) = do @@ -383,6 +412,9 @@ ssHandler e@(SaveSession fp) = saveSessionAs fp >> return e ssHandler _ = throwIDE "Leksah>>registerEvents: Impossible event" + urHandler e@UpdateRecent = updateRecentEntries >> return e + urHandler _ = throwIDE "Leksah>>registerEvents: Impossible event" + fDescription :: FieldDescription Prefs fDescription = VFD emptyParams [ mkField @@ -422,13 +454,15 @@ ok `onClicked` (do mbNewPrefs <- extract prefs [getExt] case mbNewPrefs of - Nothing -> return () + Nothing -> do + sysMessage Normal "No dialog results" + return () Just newPrefs -> do fp <- getConfigFilePathForSave "Default.prefs" writePrefs fp newPrefs widgetDestroy dialog mainQuit - firstBuild prefs) + firstBuild newPrefs) cancel `onClicked` (do widgetDestroy dialog mainQuit) @@ -449,7 +483,7 @@ firstBuild prefs = let version = cProjectVersion in do buildSourceForPackageDB prefs sources <- getSourcesMap prefs - libDir <- getSysLibDir + libDir <- getSysLibDir runGhc (Just libDir) $ collectInstalled' prefs False version True diff --git a/src/IDE/Menu.hs b/src/IDE/Menu.hs --- a/src/IDE/Menu.hs +++ b/src/IDE/Menu.hs @@ -24,6 +24,7 @@ , buildStatusbar , newIcons , setSensitivity +, updateRecentEntries ) where import Graphics.UI.Gtk @@ -49,22 +50,24 @@ import IDE.FileUtils import IDE.Pane.ClassHierarchy import IDE.Pane.Search -import IDE.Pane.Callers +import IDE.Pane.References import Paths_leksah import IDE.GUIHistory import IDE.Metainfo.Provider (rebuildLibInfo,rebuildActiveInfo) import IDE.Pane.Info (showInfo) import IDE.NotebookFlipper + -- -- | The Actions known to the system (they can be activated by keystrokes or menus) -- actions :: [ActionDescr IDERef] actions = - [(AD "File" "_File" Nothing Nothing (return ()) [] False) - ,(AD "FileNew" "_New" Nothing (Just "gtk-new") - fileNew [] False) + [AD "File" "_File" Nothing Nothing (return ()) [] False + ,AD "FileNew" "_New" Nothing (Just "gtk-new") + fileNew [] False ,AD "FileOpen" "_Open" Nothing (Just "gtk-open") fileOpen [] False + ,AD "RecentFiles" "_Recent Files" Nothing Nothing (return ()) [] False ,AD "FileRevert" "_Revert" Nothing Nothing fileRevert [] False ,AD "FileSave" "_Save" Nothing (Just "gtk-save") @@ -133,6 +136,7 @@ packageNew [] False ,AD "OpenPackage" "_Open Package" Nothing Nothing packageOpen [] False + ,AD "RecentPackages" "_Recent Packages" Nothing Nothing (return ()) [] False ,AD "EditPackage" "_Edit Package" Nothing Nothing packageEdit [] False ,AD "ClosePackage" "_Close Package" Nothing Nothing @@ -177,8 +181,8 @@ rebuildLibInfo [] False ,AD "ShowModules" "Show Modules" Nothing Nothing showModules [] False - ,AD "ShowCallers" "Show Callers" Nothing Nothing - showCallers [] False + ,AD "ShowReferences" "Show References" Nothing Nothing + showReferences [] False ,AD "ShowClasses" "Show Classes" Nothing Nothing showClasses [] False ,AD "ShowSearch" "Show Search" Nothing Nothing @@ -260,6 +264,37 @@ res <- readFile prefsPath return res +updateRecentEntries :: IDEAction +updateRecentEntries = do + recentFiles' <- readIDE recentFiles + recentPackages' <- readIDE recentPackages + recentFilesItem <- getRecentFiles + recentPackagesItem <- getRecentPackages + reifyIDE (\ ideR -> do + recentFilesMenu <- menuNew + mapM_ (\s -> do + mi <- menuItemNewWithLabel s + mi `onActivateLeaf` (reflectIDE (fileOpenThis s) ideR) + menuShellAppend recentFilesMenu mi) recentFiles' + oldSubmenu <- menuItemGetSubmenu recentFilesItem + when (isJust oldSubmenu) $ do + widgetHideAll (fromJust oldSubmenu) + widgetDestroy (fromJust oldSubmenu) + menuItemSetSubmenu recentFilesItem recentFilesMenu + widgetShowAll recentFilesMenu + recentPackagesMenu <- menuNew + mapM_ (\s -> do + mi <- menuItemNewWithLabel s + mi `onActivateLeaf` (reflectIDE (packageOpenThis (Just s) >> return ()) ideR) + menuShellAppend recentPackagesMenu mi) recentPackages' + oldSubmenu <- menuItemGetSubmenu recentPackagesItem + when (isJust oldSubmenu) $ do + widgetHideAll (fromJust oldSubmenu) + widgetDestroy (fromJust oldSubmenu) + menuItemSetSubmenu recentPackagesItem recentPackagesMenu + widgetShowAll recentPackagesMenu) + + -- -- | Building the Menu -- @@ -302,8 +337,8 @@ -- quit :: IDEAction quit = do - saveSession :: IDEAction modifyIDE_ (\ide -> return (ide{currentState = IsShuttingDown})) + saveSession :: IDEAction b <- fileCloseAll if b then liftIO mainQuit diff --git a/src/IDE/Metainfo/GHCUtils.hs b/src/IDE/Metainfo/GHCUtils.hs --- a/src/IDE/Metainfo/GHCUtils.hs +++ b/src/IDE/Metainfo/GHCUtils.hs @@ -10,27 +10,40 @@ -- -- | -- ------------------------------------------------------------------------------ module IDE.Metainfo.GHCUtils ( +----------------------------------------------------------------------------- +module IDE.Metainfo.GHCUtils ( inGhc , inGhcIO , getInstalledPackageInfos , findFittingPackages +, myParseModule +, parseHeader ) where -import GHC (setSessionDynFlags,getSessionDynFlags,runGhc,Ghc(..)) -import IDE.Core.State (IDEM(..)) -import IDE.FileUtils (getSysLibDir) -import Control.Monad.Trans (liftIO) -import PackageConfig (PackageConfig(..)) -import DynFlags (pkgDatabase,DynFlag(..),flags) +import IDE.Core.State (MessageLevel(..),sysMessage,IDEM(..),readIDE,IDE(..),IDEPackage(..)) import UniqFM (eltsUFM) import Distribution.Simple (withinRange,PackageIdentifier(..),Dependency(..)) import qualified Distribution.InstalledPackageInfo as IPI (package) -import Data.List (maximumBy) -import Distribution.Package (pkgVersion) +import GHC +import StringBuffer (StringBuffer(..),hGetStringBuffer) +import FastString (mkFastString) +import Lexer (mkPState,ParseResult(..),getMessages,unP) +import Outputable (ppr) +import Bag (unitBag) +import IDE.FileUtils (getSysLibDir) +import ErrUtils (dumpIfSet_dyn,printErrorsAndWarnings,mkPlainErrMsg,showPass,ErrMsg(..),printBagOfErrors) +import PackageConfig (PackageConfig(..)) +import Data.Foldable (maximumBy) +import DynFlags (defaultDynFlags) +import qualified Parser as P (parseModule,parseHeader) +import HscStats (ppSourceStats) +import Control.Monad.Trans +import DriverPipeline (preprocess) +import System.FilePath (takeDirectory) + inGhc :: Ghc a -> IDEM a inGhc = liftIO . inGhcIO @@ -63,4 +76,107 @@ in if length filtered > 1 then [maximumBy (\a b -> compare (pkgVersion a) (pkgVersion b)) filtered] else filtered + +parseHeader :: FilePath -> String -> IDEM (Maybe [LImportDecl RdrName]) +parseHeader fp str = do + activePack' <- readIDE activePack + case activePack' of + Nothing -> return Nothing + Just pack -> inGhc $ do + dflags <- getSessionDynFlags + let dflags2 = dflags { + topDir = takeDirectory (cabalFile pack), + hscTarget = HscNothing, + ghcMode = OneShot, + ghcLink = NoLink} + setSessionDynFlags dflags2 + session <- getSession + dynFlags <- getSessionDynFlags + (_,fp) <- preprocess session (fp,Nothing) + dynFlags <- getSessionDynFlags + liftIO $ do + stringBuffer <- hGetStringBuffer fp + parseResult <- myParseModuleHeader dynFlags fp (Just stringBuffer) + case parseResult of + Right (L _ mod) -> return (Just (hsmodImports mod)) + Left errMsg -> do + sysMessage Normal $ "Failed to parse " ++ fp + printBagOfErrors defaultDynFlags (unitBag errMsg) + return (Nothing) + + --------------------------------------------------------------------- +-- | Parser function copied here, because it is not exported + +myParseModule :: DynFlags -> FilePath -> Maybe StringBuffer + -> IO (Either ErrMsg (Located (HsModule RdrName))) +myParseModule dflags src_filename maybe_src_buf + = -------------------------- Parser ---------------- + showPass dflags "Parser" >> + {-# SCC "Parser" #-} do + + -- sometimes we already have the buffer in memory, perhaps + -- because we needed to parse the imports out of it, or get the + -- module name. + buf <- case maybe_src_buf of + Just b -> return b + Nothing -> hGetStringBuffer src_filename + + let loc = mkSrcLoc (mkFastString src_filename) 1 0 + + case unP P.parseModule (mkPState buf loc dflags) of { + + PFailed span err -> return (Left (mkPlainErrMsg span err)); + + POk pst rdr_module -> do { + + let {ms = getMessages pst}; + printErrorsAndWarnings dflags ms; + -- when (errorsFound dflags ms) $ exitWith (ExitFailure 1); + + dumpIfSet_dyn dflags Opt_D_dump_parsed "Parser" (ppr rdr_module) ; + + dumpIfSet_dyn dflags Opt_D_source_stats "Source Statistics" + (ppSourceStats False rdr_module) ; + + return (Right rdr_module) + -- ToDo: free the string buffer later. + }} + + --------------------------------------------------------------------- +-- | Parser function copied here, because it is not exported + +myParseModuleHeader :: DynFlags -> FilePath -> Maybe StringBuffer + -> IO (Either ErrMsg (Located (HsModule RdrName))) +myParseModuleHeader dflags src_filename maybe_src_buf + = -------------------------- Parser ---------------- + showPass dflags "Parser" >> + {-# SCC "Parser" #-} do + + -- sometimes we already have the buffer in memory, perhaps + -- because we needed to parse the imports out of it, or get the + -- module name. + buf <- case maybe_src_buf of + Just b -> return b + Nothing -> hGetStringBuffer src_filename + + let loc = mkSrcLoc (mkFastString src_filename) 1 0 + + case unP P.parseHeader (mkPState buf loc dflags) of { + + PFailed span err -> return (Left (mkPlainErrMsg span err)); + + POk pst rdr_module -> do { + + let {ms = getMessages pst}; + printErrorsAndWarnings dflags ms; + -- when (errorsFound dflags ms) $ exitWith (ExitFailure 1); + + dumpIfSet_dyn dflags Opt_D_dump_parsed "Parser" (ppr rdr_module) ; + + dumpIfSet_dyn dflags Opt_D_source_stats "Source Statistics" + (ppSourceStats False rdr_module) ; + + return (Right rdr_module) + -- ToDo: free the string buffer later. + }} diff --git a/src/IDE/Metainfo/InterfaceCollector.hs b/src/IDE/Metainfo/InterfaceCollector.hs --- a/src/IDE/Metainfo/InterfaceCollector.hs +++ b/src/IDE/Metainfo/InterfaceCollector.hs @@ -291,7 +291,7 @@ moduleIdMD = PM pid mid , exportedNamesMD = exportedNames , mbSourcePathMD = Nothing - , usagesMD = uses + , referencesMD = uses , idDescriptionsMD = ownDecls ++ inst ++ reexported} extractIdentifierDescr :: PackageIdentifier -> [ModuleName] -> IfaceDecl diff --git a/src/IDE/Metainfo/Provider.hs b/src/IDE/Metainfo/Provider.hs --- a/src/IDE/Metainfo/Provider.hs +++ b/src/IDE/Metainfo/Provider.hs @@ -65,6 +65,7 @@ import Text.Regex.Posix.String (execute,compile) import IDE.Metainfo.GHCUtils (findFittingPackages,getInstalledPackageInfos,inGhc) import Data.Binary.Shared (decodeSer) +import System.Mem (performGC) -- -- | Lookup of an identifier description @@ -224,6 +225,7 @@ let scope = foldr buildScope (Map.empty,Map.empty) $ map fromJust $ filter isJust packageList + liftIO performGC modifyIDE_ (\ide -> return (ide{accessibleInfo = (Just scope)})) -- @@ -504,7 +506,7 @@ deepSeq pd = deepSeq (moduleIdMD pd) $ deepSeq (mbSourcePathMD pd) $ deepSeq (exportedNamesMD pd) - $ deepSeq (usagesMD pd) + $ deepSeq (referencesMD pd) instance DeepSeq Descr where deepSeq (Descr descrName' typeInfo' descrModu' diff --git a/src/IDE/Metainfo/SourceCollector.hs b/src/IDE/Metainfo/SourceCollector.hs --- a/src/IDE/Metainfo/SourceCollector.hs +++ b/src/IDE/Metainfo/SourceCollector.hs @@ -47,10 +47,7 @@ import Bag import ErrUtils import FastString -import Lexer hiding (lexer) -import qualified Parser as P import Outputable hiding (char) -import HscStats import IDE.Core.State import IDE.FileUtils @@ -61,6 +58,7 @@ import Distribution.Text (display) import DriverPipeline (preprocess) import GHC.Show (showSpace) +import IDE.Metainfo.GHCUtils (myParseModule) -- --------------------------------------------------------------------- @@ -102,6 +100,7 @@ setSessionDynFlags dflags2 let flags = ["-fglasgow-exts"] ++ ["-cpp"] + ++ ["-w"] ++ ["-I" ++ dir | dir <- includes] ++ ["-I" ++ dir | dir <- buildPaths] ++ ["-i" ++ dir | dir <- includes] @@ -336,43 +335,6 @@ load LoadAllTargets return () - --------------------------------------------------------------------- --- | Parser function copied here, because it is not exported - -myParseModule :: DynFlags -> FilePath -> Maybe StringBuffer - -> IO (Either ErrMsg (Located (HsModule RdrName))) -myParseModule dflags src_filename maybe_src_buf - = -------------------------- Parser ---------------- - showPass dflags "Parser" >> - {-# SCC "Parser" #-} do - - -- sometimes we already have the buffer in memory, perhaps - -- because we needed to parse the imports out of it, or get the - -- module name. - buf <- case maybe_src_buf of - Just b -> return b - Nothing -> hGetStringBuffer src_filename - - let loc = mkSrcLoc (mkFastString src_filename) 1 0 - - case unP P.parseModule (mkPState buf loc dflags) of { - - PFailed span err -> return (Left (mkPlainErrMsg span err)); - - POk pst rdr_module -> do { - - let {ms = getMessages pst}; - printErrorsAndWarnings dflags ms; - -- when (errorsFound dflags ms) $ exitWith (ExitFailure 1); - - dumpIfSet_dyn dflags Opt_D_dump_parsed "Parser" (ppr rdr_module) ; - - dumpIfSet_dyn dflags Opt_D_source_stats "Source Statistics" - (ppSourceStats False rdr_module) ; - - return (Right rdr_module) - -- ToDo: free the string buffer later. - }} -- --------------------------------------------------------------------- -- Function to map packages to file paths diff --git a/src/IDE/NotebookFlipper.hs b/src/IDE/NotebookFlipper.hs --- a/src/IDE/NotebookFlipper.hs +++ b/src/IDE/NotebookFlipper.hs @@ -18,7 +18,6 @@ ) where import Graphics.UI.Gtk -import Graphics.UI.Gtk.ModelView as New import Graphics.UI.Frame.Panes (IDEPane(..)) import IDE.Core.State import Control.Monad.Trans (liftIO) @@ -45,36 +44,36 @@ -- | Moves down in the Flipper state moveFlipperDown :: TreeViewClass alpha => alpha -> IDEAction moveFlipperDown tree = liftIO $ do - mbStore <- New.treeViewGetModel tree + mbStore <- treeViewGetModel tree case mbStore of Nothing -> throwIDE "NotebookFlipper>>setFlipper: no store" Just store -> do - n <- New.treeModelIterNChildren store Nothing + n <- treeModelIterNChildren store Nothing when (n /= 0) $ do - (cl, _) <- New.treeViewGetCursor tree + (cl, _) <- treeViewGetCursor tree case cl of (current:_) -> let next = if current == n - 1 then 0 else current + 1 - in New.treeViewSetCursor tree [min (n-1) next] Nothing - [] -> New.treeViewSetCursor tree [1] Nothing + in treeViewSetCursor tree [min (n-1) next] Nothing + [] -> treeViewSetCursor tree [1] Nothing -- | Moves up in the Flipper state moveFlipperUp :: TreeViewClass alpha => alpha -> IDEAction moveFlipperUp tree = liftIO $ do - mbStore <- New.treeViewGetModel tree + mbStore <- treeViewGetModel tree case mbStore of Nothing -> throwIDE "NotebookFlipper>>setFlipper: no store" Just store -> do - n <- New.treeModelIterNChildren store Nothing + n <- treeModelIterNChildren store Nothing when (n /= 0) $ do - (cl, _) <- New.treeViewGetCursor tree + (cl, _) <- treeViewGetCursor tree case cl of (current:_) -> let next = if current == 0 then n - 1 else current - 1 - in New.treeViewSetCursor tree [min (n-1) next] Nothing - [] -> New.treeViewSetCursor tree [n-1] Nothing + in treeViewSetCursor tree [min (n-1) next] Nothing + [] -> treeViewSetCursor tree [n-1] Nothing -- | Initiate Filpper , If True moves down, if false up initFlipper :: Bool -> IDEAction @@ -87,26 +86,26 @@ set window [windowResizable := True] frame <- frameNew containerAdd window frame - tree <- New.treeViewNew + tree <- treeViewNew containerAdd frame tree - store <- New.listStoreNew recentPanes' - New.treeViewSetModel tree store - column <- New.treeViewColumnNew - New.treeViewAppendColumn tree column - renderer <- New.cellRendererTextNew - New.treeViewColumnPackStart column renderer True + store <- listStoreNew recentPanes' + treeViewSetModel tree store + column <- treeViewColumnNew + treeViewAppendColumn tree column + renderer <- cellRendererTextNew + treeViewColumnPackStart column renderer True cellLayoutSetAttributes column renderer store - (\str -> [ New.cellText := str]) + (\str -> [ cellText := str]) - set tree [New.treeViewHeadersVisible := False] + set tree [treeViewHeadersVisible := False] cid <- onKeyRelease mainWindow $ handleKeyRelease tree ideR - New.onRowActivated tree (\treePath column -> do + onRowActivated tree (\treePath column -> do signalDisconnect cid let [row] = treePath - string <- New.listStoreGetValue store row + string <- listStoreGetValue store row reflectIDE (do mbPane <- mbPaneFromName string case mbPane of @@ -115,8 +114,8 @@ widgetHideAll window widgetDestroy window) set window [windowWindowPosition := WinPosCenterOnParent] - n <- New.treeModelIterNChildren store Nothing - New.treeViewSetCursor tree [if direction then min 1 (n-1) else (n-1)] Nothing + n <- treeModelIterNChildren store Nothing + treeViewSetCursor tree [if direction then min 1 (n-1) else (n-1)] Nothing widgetShowAll window return tree modifyIDE_ (\ide -> return (ide{currentState = IsFlipping tree'})) @@ -129,9 +128,9 @@ currentState' <- reflectIDE (readIDE currentState) ideR case currentState' of IsFlipping tv -> do - (treePath, _) <- New.treeViewGetCursor tree - Just column <- New.treeViewGetColumn tree 0 - New.treeViewRowActivated tree treePath column + (treePath, _) <- treeViewGetCursor tree + Just column <- treeViewGetColumn tree 0 + treeViewRowActivated tree treePath column reflectIDE (modifyIDE_ (\ide -> return (ide{currentState = IsRunning}))) ideR return True _ -> return False diff --git a/src/IDE/Package.hs b/src/IDE/Package.hs --- a/src/IDE/Package.hs +++ b/src/IDE/Package.hs @@ -17,6 +17,7 @@ module IDE.Package ( packageOpen +, packageOpenThis , packageNew , packageConfig , packageBuild @@ -72,32 +73,37 @@ import MyMissing (replace) import Distribution.ModuleName (ModuleName(..)) import Data.List (foldl') +import qualified System.IO.UTF8 as UTF8 (readFile) packageNew :: IDEAction packageNew = packageNew' (\fp -> activatePackage fp >> return ()) packageOpen :: IDEAction -packageOpen = do +packageOpen = packageOpenThis Nothing + +packageOpenThis :: Maybe FilePath -> IDEAction +packageOpenThis mbFilePath = do active <- readIDE activePack case active of Just p -> deactivatePackage Nothing -> return () - selectActivePackage + selectActivePackage mbFilePath return () - getActivePackage :: IDEM (Maybe IDEPackage) getActivePackage = do active <- readIDE activePack case active of Just p -> return (Just p) - Nothing -> selectActivePackage + Nothing -> selectActivePackage Nothing -selectActivePackage :: IDEM (Maybe IDEPackage) -selectActivePackage = do +selectActivePackage :: Maybe FilePath -> IDEM (Maybe IDEPackage) +selectActivePackage mbFilePath' = do ideR <- ask window <- readIDE window - mbFilePath <- liftIO $choosePackageFile window + mbFilePath <- case mbFilePath' of + Nothing -> liftIO $ choosePackageFile window + Just fp -> return (Just fp) case mbFilePath of Nothing -> return Nothing Just filePath -> do @@ -145,6 +151,7 @@ sb <- getSBActivePackage liftIO $ statusbarPop sb 1 liftIO $ statusbarPush sb 1 (display $ packageId pack) + removeRecentlyUsedPackage filePath return (Just pack) deactivatePackage :: IDEAction @@ -154,6 +161,7 @@ when (isJust oldActivePack) $ do triggerEvent ideR (SaveSession ((dropFileName . cabalFile . fromJust) oldActivePack "IDE.session")) + addRecentlyUsedPackage ((cabalFile . fromJust) oldActivePack) return () modifyIDE_ (\ide -> return (ide{activePack = Nothing})) ideR <- ask @@ -611,7 +619,7 @@ getModuleTemplate :: PackageDescription -> String -> IO String getModuleTemplate pd modName = do filePath <- getConfigFilePathForLoad "Module.template" - template <- readFile filePath + template <- UTF8.readFile filePath return (foldl' (\ a (from, to) -> replace from to a) template [("@License@", (show . license) pd), ("@Maintainer@", maintainer pd), ("@Stability@",stability pd), ("@Portability@",""), @@ -651,3 +659,24 @@ where addModToBuildInfo :: BuildInfo -> ModuleName -> BuildInfo addModToBuildInfo bi mn = bi {otherModules = mn : otherModules bi} + + +addRecentlyUsedPackage :: FilePath -> IDEAction +addRecentlyUsedPackage fp = do + state <- readIDE currentState + when (not $ isStartingOrClosing state) $ do + recentPackages' <- readIDE recentPackages + unless (elem fp recentPackages') $ + modifyIDE_ (\ide -> return ide{recentPackages = take 12 (fp : recentPackages')}) + ask >>= \ideR -> triggerEvent ideR UpdateRecent + return () + +removeRecentlyUsedPackage :: FilePath -> IDEAction +removeRecentlyUsedPackage fp = do + state <- readIDE currentState + when (not $ isStartingOrClosing state) $ do + recentPackages' <- readIDE recentPackages + when (elem fp recentPackages') $ + modifyIDE_ (\ide -> return ide{recentPackages = filter (\e -> e /= fp) recentPackages'}) + ask >>= \ideR -> triggerEvent ideR UpdateRecent + return () diff --git a/src/IDE/Pane/Callers.hs b/src/IDE/Pane/Callers.hs deleted file mode 100644 --- a/src/IDE/Pane/Callers.hs +++ /dev/null @@ -1,275 +0,0 @@ -{-# OPTIONS_GHC -XDeriveDataTypeable -XMultiParamTypeClasses -XTypeSynonymInstances #-} ------------------------------------------------------------------------------ --- --- Module : IDE.Pane.Callers --- Copyright : (c) Juergen Nicklisch-Franken (aka Jutaro) --- License : GNU-GPL --- --- Maintainer : Juergen Nicklisch-Franken --- Stability : experimental --- Portability : portable --- --- | The pane of ide where modules are presented in tree form with their --- packages and exports --- -------------------------------------------------------------------------------- - -module IDE.Pane.Callers ( - IDECallers(..) -, CallersState -, calledBy -, showCallers -) where - -import Graphics.UI.Gtk hiding (get) -import Graphics.UI.Gtk.ModelView as New -import IDE.Find (focusFindEntry,showFindbar,setFindState,entryStr, getFindState, editFind) -import IDE.Pane.SourceBuffer (selectSourceBuf) -import Graphics.UI.Gtk.Gdk.Events -import Data.IORef (newIORef,writeIORef,readIORef,IORef(..)) -import Data.Maybe -import Control.Monad.Reader -import qualified Data.Map as Map -import qualified Data.Set as Set -import Data.List -import Data.Typeable -import Distribution.ModuleName(ModuleName) -import Distribution.Text -import Text.PrettyPrint (render) - -import IDE.Core.State - - --- | A callers pane description --- - -data IDECallers = IDECallers { - scrolledView :: ScrolledWindow -, treeViewC :: New.TreeView -, callersDescr :: IORef (Maybe Descr) -, callersStore :: New.ListStore (ModuleDescr,Symbol) -, callersEntry :: Entry -, topBox :: VBox -} deriving Typeable - -data CallersState = CallersState (Maybe Descr) - deriving(Eq,Ord,Read,Show,Typeable) - - -instance IDEObject IDECallers - -instance Pane IDECallers IDEM - where - primPaneName _ = "Usage" - getAddedIndex _ = 0 - getTopWidget = castToWidget . topBox - paneId b = "*Usage" - makeActive p = activatePane p [] - close = closePane - - --- | We don't recover this pane -instance RecoverablePane IDECallers CallersState IDEM where - saveState p = do - mbDescr <- liftIO $ readIORef (callersDescr p) - return (Just (CallersState mbDescr)) - recoverState pp (CallersState mbDescr) = do - nb <- getNotebook pp - initCallers pp nb - when (isJust mbDescr) (calledBy (fromJust mbDescr)) - -showCallers :: IDEAction -showCallers = do - m <- getCallers - liftIO $ bringPaneToFront m - liftIO $ widgetGrabFocus (treeViewC m) - - --- | Open a pane with the callers of this identifier -calledBy :: Descr -> IDEAction -calledBy idDescr = do - mbCurrentInfo <- readIDE currentInfo - case mbCurrentInfo of - Nothing -> return () - Just currentInfo' -> - let symModPair = (descrName idDescr, modu $ descrModu idDescr) - modulesList1 = modulesForCallerFromPackages - (Map.elems $ fst $ fst currentInfo') symModPair - modulesList2 = modulesForCallerFromPackages - (Map.elems $ fst $ snd currentInfo') symModPair - modulesList = nub $ modulesList1 ++ modulesList2 - finalList = sort $ zip modulesList (repeat (descrName idDescr)) - in do callers <- getCallers - liftIO $ do - writeIORef (callersDescr callers) (Just idDescr) - New.listStoreClear (callersStore callers) - mapM_ (New.listStoreAppend (callersStore callers)) finalList - entrySetText (callersEntry callers) - $ descrName idDescr ++ - " << " ++ showPackModule (descrModu idDescr) - bringPaneToFront callers - -modulesForCallerFromPackages :: [PackageDescr] -> (Symbol,ModuleName) -> [ModuleDescr] -modulesForCallerFromPackages [] _ = [] -modulesForCallerFromPackages (p :rest) (sym,mod) = - (filter (\ md -> case mod `Map.lookup` (usagesMD md) of - Nothing -> False - Just syms -> sym `Set.member` syms) (exposedModulesPD p)) - ++ modulesForCallerFromPackages rest (sym,mod) - -getCallers :: IDEM IDECallers -getCallers = do - mbMod <- getPane - case mbMod of - Nothing -> do - prefs <- readIDE prefs - layout <- readIDE layout - let pp = getStandardPanePath (modulesPanePath prefs) layout - nb <- getNotebook pp - initCallers pp nb - mbMod <- getPane - case mbMod of - Nothing -> throwIDE "Can't init callers" - Just m -> return m - Just m -> return m - -initCallers :: PanePath -> Notebook -> IDEAction -initCallers panePath nb = do - panes <- readIDE panes - paneMap <- readIDE paneMap - prefs <- readIDE prefs - currentInfo <- readIDE currentInfo - (buf,cids) <- reifyIDE $ \ideR -> do - listStore <- New.listStoreNew [] - treeView <- New.treeViewNew - New.treeViewSetModel treeView listStore - - renderer0 <- New.cellRendererPixbufNew - set renderer0 [ cellPixbufStockId := stockYes ] - - renderer <- New.cellRendererTextNew - col <- New.treeViewColumnNew - New.treeViewColumnSetTitle col "Modules" - New.treeViewColumnSetSizing col TreeViewColumnAutosize - New.treeViewColumnSetResizable col True - New.treeViewColumnSetReorderable col True - New.treeViewAppendColumn treeView col - New.cellLayoutPackStart col renderer0 False - New.cellLayoutPackStart col renderer True - New.cellLayoutSetAttributes col renderer listStore - $ \row -> [ New.cellText := render $ disp $ modu $ moduleIdMD $ fst row] - New.cellLayoutSetAttributes col renderer0 listStore - $ \row -> [cellPixbufStockId := - if isJust (mbSourcePathMD $ fst row) - then stockJumpTo - else stockYes] - - renderer2 <- New.cellRendererTextNew - col2 <- New.treeViewColumnNew - New.treeViewColumnSetTitle col2 "Packages" - New.treeViewColumnSetSizing col2 TreeViewColumnAutosize - New.treeViewColumnSetResizable col True - New.treeViewColumnSetReorderable col2 True - New.treeViewAppendColumn treeView col2 - New.cellLayoutPackStart col2 renderer2 True - New.cellLayoutSetAttributes col2 renderer2 listStore - $ \row -> [ New.cellText := render $ disp $ pack $ moduleIdMD $ fst row] - - New.treeViewSetHeadersVisible treeView True - sel <- New.treeViewGetSelection treeView - New.treeSelectionSetMode sel SelectionSingle - - sw <- scrolledWindowNew Nothing Nothing - containerAdd sw treeView - scrolledWindowSetPolicy sw PolicyAutomatic PolicyAutomatic - entry <- entryNew - set entry [ entryEditable := False ] - box <- vBoxNew False 2 - boxPackStart box entry PackNatural 0 - boxPackEnd box sw PackGrow 0 - callersDescr' <- newIORef Nothing - let callers = IDECallers sw treeView callersDescr' listStore entry box - notebookInsertOrdered nb box (paneName callers) Nothing - widgetShowAll box - cid1 <- treeView `afterFocusIn` - (\_ -> do reflectIDE (makeActive callers) ideR ; return True) - treeView `onButtonPress` (treeViewPopup ideR callers) - return (callers,[ConnectC cid1]) - addPaneAdmin buf cids panePath - liftIO $widgetGrabFocus (scrolledView buf) - - -getSelectionTree :: New.TreeView - -> New.ListStore (ModuleDescr,Symbol) - -> IO (Maybe (ModuleDescr,Symbol)) -getSelectionTree treeView listStore = do - treeSelection <- New.treeViewGetSelection treeView - rows <- New.treeSelectionGetSelectedRows treeSelection - case rows of - [[n]] -> do - val <- New.listStoreGetValue listStore n - return (Just val) - _ -> return Nothing - -treeViewPopup :: IDERef - -> IDECallers - -> Event - -> IO (Bool) -treeViewPopup ideR callers (Button _ click _ _ _ _ button _ _) = do - if button == RightButton - then do - theMenu <- menuNew - item1 <- menuItemNewWithLabel "Edit" - item1 `onActivateLeaf` do - sel <- getSelectionTree (treeViewC callers) (callersStore callers) - case sel of - Just (m,_) -> case mbSourcePathMD m of - Nothing -> return () - Just fp -> do - text <- entryGetText (callersEntry callers) - case words text of - (hd : tl) -> do - reflectIDE (selectText fp hd) ideR - return () - _ -> return () - otherwise -> return () - menuShellAppend theMenu item1 - menuPopup theMenu Nothing - widgetShowAll theMenu - return True - else if button == LeftButton && click == DoubleClick - then do sel <- getSelectionTree (treeViewC callers) - (callersStore callers) - case sel of - Just (m,_) - -> case mbSourcePathMD m of - Nothing -> return False - Just fp -> do - text <- entryGetText (callersEntry callers) - case words text of - (hd : tl) -> do - reflectIDE (selectText fp hd) ideR - return True - _ -> return False - otherwise -> return False - else return False -treeViewPopup _ _ _ = throwIDE "treeViewPopup wrong event type" - -selectText :: FilePath -> String -> IDEM Bool -selectText fp text = do - res <- selectSourceBuf fp - fs <- getFindState - case res of - Nothing -> return False - Just _ -> do - setFindState fs {entryStr = text} - showFindbar - focusFindEntry - reifyIDE $ \ideR -> do - idleAdd (do - reflectIDE (editFind True True True text "" Forward) ideR - return False) - priorityDefaultIdle - return True - - diff --git a/src/IDE/Pane/ClassHierarchy.hs b/src/IDE/Pane/ClassHierarchy.hs --- a/src/IDE/Pane/ClassHierarchy.hs +++ b/src/IDE/Pane/ClassHierarchy.hs @@ -25,7 +25,6 @@ ) where import Graphics.UI.Gtk hiding (get) -import Graphics.UI.Gtk.ModelView as New import Data.Maybe import Control.Monad.Reader import qualified Data.Map as Map @@ -43,10 +42,10 @@ data IDEClassHierarchy = IDEClassHierarchy { outer :: VBox , paned :: HPaned -, treeView :: New.TreeView -, treeStore :: New.TreeStore ClassWrapper ---, facetView :: New.TreeView ---, facetStore :: New.TreeStore FacetWrapper +, treeView :: TreeView +, treeStore :: TreeStore ClassWrapper +--, facetView :: TreeView +--, facetStore :: TreeStore FacetWrapper , localScopeB :: RadioButton , packageScopeB :: RadioButton , worldScopeB :: RadioButton @@ -125,19 +124,19 @@ mbTree <- liftIO $ treeStoreGetTreeSave treeStore [] case treePathFromNameArray mbTree nameArray [] of Just treePath -> liftIO $ do - New.treeViewExpandToPath treeView treePath - sel <- New.treeViewGetSelection treeView - New.treeSelectionSelectPath sel treePath - col <- New.treeViewGetColumn treeView 0 - New.treeViewScrollToCell treeView treePath (fromJust col) (Just (0.3,0.3)) + 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 <- New.treeViewGetSelection facetView + selF <- treeViewGetSelection facetView case findPathFor symbol mbFacetTree of Nothing -> sysMessage Normal "no path found" Just path -> do - New.treeSelectionSelectPath selF path - col <- New.treeViewGetColumn facetView 0 - New.treeViewScrollToCell facetView path (fromJust col) (Just (0.3,0.3)) + treeSelectionSelectPath selF path + col <- treeViewGetColumn facetView 0 + treeViewScrollToCell facetView path (fromJust col) (Just (0.3,0.3)) bringPaneToFront mods Nothing -> return () --} @@ -257,66 +256,66 @@ let forest = case currentInfo of Nothing -> [] Just pair -> buildClassHierarchyTree pair - treeStore <- New.treeStoreNew forest - treeView <- New.treeViewNew - New.treeViewSetModel treeView treeStore - --New.treeViewSetRulesHint treeView True + treeStore <- treeStoreNew forest + treeView <- treeViewNew + treeViewSetModel treeView treeStore + --treeViewSetRulesHint treeView True - renderer0 <- New.cellRendererPixbufNew + renderer0 <- cellRendererPixbufNew set renderer0 [ cellPixbufStockId := "ide_no_source" ] - renderer <- New.cellRendererTextNew - col <- New.treeViewColumnNew - New.treeViewColumnSetTitle col "Classes" - New.treeViewColumnSetSizing col TreeViewColumnAutosize - New.treeViewColumnSetResizable col True - New.treeViewColumnSetReorderable col True - New.treeViewAppendColumn treeView col - New.cellLayoutPackStart col renderer0 False - New.cellLayoutPackStart col renderer True - New.cellLayoutSetAttributes col renderer treeStore - $ \(s,_,_) -> [ New.cellText := s] - New.cellLayoutSetAttributes col renderer0 treeStore + 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"] - New.treeViewSetHeadersVisible treeView True - -- New.treeViewSetEnableSearch treeView True - -- New.treeViewSetSearchColumn treeView 0 - -- New.treeViewSetSearchEqualFunc treeView (treeViewSearch treeView treeStore) + treeViewSetHeadersVisible treeView True + -- treeViewSetEnableSearch treeView True + -- treeViewSetSearchColumn treeView 0 + -- treeViewSetSearchEqualFunc treeView (treeViewSearch treeView treeStore) -- Facet view {-- - facetView <- New.treeViewNew - facetStore <- New.treeStoreNew [] - New.treeViewSetModel facetView facetStore - renderer30 <- New.cellRendererPixbufNew - renderer31 <- New.cellRendererPixbufNew - renderer3 <- New.cellRendererTextNew - col <- New.treeViewColumnNew - New.treeViewColumnSetTitle col "Interface" - --New.treeViewColumnSetSizing col TreeViewColumnAutosize - New.treeViewAppendColumn facetView col - New.cellLayoutPackStart col renderer30 False - New.cellLayoutPackStart col renderer31 False - New.cellLayoutPackStart col renderer3 True - New.cellLayoutSetAttributes col renderer3 facetStore - $ \row -> [ New.cellText := facetTreeText row] - New.cellLayoutSetAttributes col renderer30 facetStore + 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)] - New.cellLayoutSetAttributes col renderer31 facetStore + cellLayoutSetAttributes col renderer31 facetStore $ \row -> [ cellPixbufStockId := if isJust (mbLocation(facetIdDescr row)) then "ide_source" else ""] - New.treeViewSetHeadersVisible facetView True - New.treeViewSetEnableSearch facetView True - New.treeViewSetSearchColumn facetView 0 - New.treeViewSetSearchEqualFunc facetView (facetViewSearch facetView facetStore) + treeViewSetHeadersVisible facetView True + treeViewSetEnableSearch facetView True + treeViewSetSearchColumn facetView 0 + treeViewSetSearchEqualFunc facetView (facetViewSearch facetView facetStore) --} pane' <- hPanedNew sw <- scrolledWindowNew Nothing Nothing @@ -350,9 +349,9 @@ {--facetView facetStore--} rb1 rb2 rb3 cb notebookInsertOrdered nb boxOuter (paneName classes) Nothing widgetShowAll boxOuter - cid3 <- treeView `New.onRowActivated` + cid3 <- treeView `onRowActivated` (\ treePath _ -> do - New.treeViewExpandRow treeView treePath False + treeViewExpandRow treeView treePath False return ()) cid1 <- treeView `afterFocusIn` (\_ -> do reflectIDE (makeActive classes) ideR; return True) @@ -364,10 +363,10 @@ -- rb2 `onToggled` (runReaderT scopeSelection ideR) -- rb3 `onToggled` (runReaderT scopeSelection ideR) -- cb `onToggled` (runReaderT scopeSelection ideR) - sel <- New.treeViewGetSelection treeView --- sel `New.onSelectionChanged` (fillFacets treeView treeStore facetView facetStore) --- sel2 <- New.treeViewGetSelection facetView --- sel2 `New.onSelectionChanged` (fillInfo facetView facetStore 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 @@ -376,20 +375,20 @@ {-- treeViewSearch :: TreeView - -> New.TreeStore (String, [(ModuleDescr,PackageDescr)]) + -> TreeStore (String, [(ModuleDescr,PackageDescr)]) -> Int -> String -> TreeIter -> IO Bool treeViewSearch treeView treeStore _ string iter = do - path <- New.treeModelGetPath treeStore iter - val <- New.treeStoreGetValue treeStore path + path <- treeModelGetPath treeStore iter + val <- treeStoreGetValue treeStore path mbTree <- treeStoreGetTreeSave treeStore path - exp <- New.treeViewRowExpanded treeView 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 - New.treeViewExpandRow treeView path False + treeViewExpandRow treeView path False return () let str2 = case snd val of [] -> fst val @@ -407,20 +406,20 @@ $ concatMap flatten (subForest tree) facetViewSearch :: TreeView - -> New.TreeStore FacetWrapper + -> TreeStore FacetWrapper -> Int -> String -> TreeIter -> IO Bool facetViewSearch facetView facetStore _ string iter = do - path <- New.treeModelGetPath facetStore iter - val <- New.treeStoreGetValue facetStore path - tree <- New.treeStoreGetTree facetStore path - exp <- New.treeViewRowExpanded facetView path + 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 - New.treeViewExpandRow facetView path False + treeViewExpandRow facetView path False return () return (isInfixOf (map toLower string) (map toLower (facetTreeText val))) @@ -433,10 +432,10 @@ --} {-- -fillFacets :: New.TreeView - -> New.TreeStore (String, [(ModuleDescr,PackageDescr)]) - -> New.TreeView - -> New.TreeStore FacetWrapper +fillFacets :: TreeView + -> TreeStore (String, [(ModuleDescr,PackageDescr)]) + -> TreeView + -> TreeStore FacetWrapper -> IO () fillFacets treeView treeStore facetView facetStore = do sel <- getSelectionTree treeView treeStore @@ -445,59 +444,59 @@ -> case snd val of ((mod,package):_) -> let forest = buildFacetForest mod in do - emptyModel <- New.treeStoreNew [] - New.treeViewSetModel facetView emptyModel - New.treeStoreClear facetStore - mapM_ (\(e,i) -> New.treeStoreInsertTree facetStore [] i e) + emptyModel <- treeStoreNew [] + treeViewSetModel facetView emptyModel + treeStoreClear facetStore + mapM_ (\(e,i) -> treeStoreInsertTree facetStore [] i e) $ zip forest [0 .. length forest] - New.treeViewSetModel facetView facetStore - New.treeViewSetEnableSearch facetView True - New.treeViewSetSearchColumn facetView 0 - New.treeViewSetSearchEqualFunc facetView (facetViewSearch facetView facetStore) + treeViewSetModel facetView facetStore + treeViewSetEnableSearch facetView True + treeViewSetSearchColumn facetView 0 + treeViewSetSearchEqualFunc facetView (facetViewSearch facetView facetStore) [] -> return () Nothing -> do - New.treeStoreClear facetStore + treeStoreClear facetStore return () --} {-- -getSelectionTree :: New.TreeView - -> New.TreeStore (String, [(ModuleDescr,PackageDescr)]) +getSelectionTree :: TreeView + -> TreeStore (String, [(ModuleDescr,PackageDescr)]) -> IO (Maybe (String, [(ModuleDescr,PackageDescr)])) getSelectionTree treeView treeStore = do - treeSelection <- New.treeViewGetSelection treeView - paths <- New.treeSelectionGetSelectedRows treeSelection + treeSelection <- treeViewGetSelection treeView + paths <- treeSelectionGetSelectedRows treeSelection case paths of [] -> return Nothing a:r -> do - val <- New.treeStoreGetValue treeStore a + val <- treeStoreGetValue treeStore a return (Just val) -getSelectionFacet :: New.TreeView - -> New.TreeStore FacetWrapper +getSelectionFacet :: TreeView + -> TreeStore FacetWrapper -> IO (Maybe FacetWrapper) getSelectionFacet treeView treeStore = do - treeSelection <- New.treeViewGetSelection treeView - paths <- New.treeSelectionGetSelectedRows treeSelection + treeSelection <- treeViewGetSelection treeView + paths <- treeSelectionGetSelectedRows treeSelection case paths of a:r -> do - val <- New.treeStoreGetValue treeStore a + val <- treeStoreGetValue treeStore a return (Just val) _ -> return Nothing -fillInfo :: New.TreeView - -> New.TreeStore FacetWrapper +fillInfo :: TreeView + -> TreeStore FacetWrapper -> IDERef -> IO () fillInfo treeView lst ideR = do - treeSelection <- New.treeViewGetSelection treeView - paths <- New.treeSelectionGetSelectedRows treeSelection + treeSelection <- treeViewGetSelection treeView + paths <- treeSelectionGetSelectedRows treeSelection case paths of [] -> return () [a] -> do - wrapper <- New.treeStoreGetValue lst a + wrapper <- treeStoreGetValue lst a runReaderT (setInfos [facetIdDescr wrapper]) ideR return () _ -> return () @@ -526,12 +525,12 @@ (Node _ li) = buildModulesTree ((Map.empty,Map.empty),p2) in liftIO $ do - New.treeStoreClear treeStore - mapM_ (\(e,i) -> New.treeStoreInsertTree treeStore [] i e) + treeStoreClear treeStore + mapM_ (\(e,i) -> treeStoreInsertTree treeStore [] i e) $ zip li [0 .. length li] _ -> liftIO $ do - New.treeStoreClear treeStore - New.treeStoreInsertTree treeStore [] 0 (Node ("",[]) []) + 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) @@ -544,15 +543,15 @@ else p' (Node _ li) = buildModulesTree (l',p2) in liftIO $ do - emptyModel <- New.treeStoreNew [] - New.treeViewSetModel treeView emptyModel - New.treeStoreClear treeStore - mapM_ (\(e,i) -> New.treeStoreInsertTree treeStore [] i e) + emptyModel <- treeStoreNew [] + treeViewSetModel treeView emptyModel + treeStoreClear treeStore + mapM_ (\(e,i) -> treeStoreInsertTree treeStore [] i e) $ zip li [0 .. length li] - New.treeViewSetModel treeView treeStore - New.treeViewSetEnableSearch treeView True - New.treeViewSetSearchColumn treeView 0 - New.treeViewSetSearchEqualFunc treeView (treeViewSearch treeView treeStore) + treeViewSetModel treeView treeStore + treeViewSetEnableSearch treeView True + treeViewSetSearchColumn treeView 0 + treeViewSetSearchEqualFunc treeView (treeViewSearch treeView treeStore) where filterBlacklist :: [Dependency] -> PackageDescr -> Bool @@ -650,8 +649,8 @@ {-- treeViewPopup :: IDERef - -> New.TreeStore (String, [(ModuleDescr,PackageDescr)]) - -> New.TreeView + -> TreeStore (String, [(ModuleDescr,PackageDescr)]) + -> TreeView -> Event -> IO (Bool) treeViewPopup ideR store treeView (Button _ click _ _ _ _ button _ _) = do @@ -669,9 +668,9 @@ return () otherwise -> return () item2 <- menuItemNewWithLabel "ExpandAll" - item2 `onActivateLeaf` (New.treeViewExpandAll treeView) + item2 `onActivateLeaf` (treeViewExpandAll treeView) item3 <- menuItemNewWithLabel "CollapseAll" - item3 `onActivateLeaf` (New.treeViewCollapseAll treeView) + item3 `onActivateLeaf` (treeViewCollapseAll treeView) mapM_ (menuShellAppend theMenu) [item1,item2,item3] menuPopup theMenu Nothing widgetShowAll theMenu @@ -690,8 +689,8 @@ treeViewPopup _ _ _ _ = throwIDE "treeViewPopup wrong event type" facetViewPopup :: IDERef - -> New.TreeStore FacetWrapper - -> New.TreeView + -> TreeStore FacetWrapper + -> TreeView -> Event -> IO (Bool) facetViewPopup ideR store facetView (Button _ click _ _ _ _ button _ _) = do @@ -751,8 +750,8 @@ mbFacetSelection <- liftIO $ getSelectionFacet facetView facetStore sc <- getScope - ts <- liftIO $ New.treeViewGetSelection treeView - liftIO $ New.treeSelectionUnselectAll ts + ts <- liftIO $ treeViewGetSelection treeView + liftIO $ treeSelectionUnselectAll ts fillModulesList sc let mbs = (case mbTreeSelection of Nothing -> Nothing @@ -777,23 +776,23 @@ case treePathFromNameArray mbTree nameArray [] of Nothing -> return () Just treePath -> liftIO $ do - New.treeViewExpandToPath treeView treePath - sel <- New.treeViewGetSelection treeView - New.treeSelectionSelectPath sel treePath - col <- New.treeViewGetColumn treeView 0 - New.treeViewScrollToCell treeView treePath (fromJust col) + 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 <- New.treeViewGetSelection facetView + selF <- treeViewGetSelection facetView case findPathFor symbol mbFacetTree of Nothing -> sysMessage Normal "no path found" Just path -> do - New.treeSelectionSelectPath selF path - col <- New.treeViewGetColumn facetView 0 - New.treeViewScrollToCell facetView path (fromJust col) + treeSelectionSelectPath selF path + col <- treeViewGetColumn facetView 0 + treeViewScrollToCell facetView path (fromJust col) (Just (0.3,0.3)) @@ -815,7 +814,7 @@ mbFacetSelection <- liftIO $ getSelectionFacet facetView facetStore sc <- getScope fillModulesList sc - liftIO $ New.treeStoreClear facetStore + liftIO $ treeStoreClear facetStore let mbs = (case mbTreeSelection of Nothing -> Nothing Just (_,[]) -> Nothing @@ -826,7 +825,7 @@ selectNames mbs -treeStoreGetTreeSave :: New.TreeStore a -> TreePath -> IO (Maybe (Tree a)) +treeStoreGetTreeSave :: TreeStore a -> TreePath -> IO (Maybe (Tree a)) treeStoreGetTreeSave treeStore treePath = catch (do res <- treeStoreGetTree treeStore treePath return (Just res)) (\ _ -> return Nothing) diff --git a/src/IDE/Pane/Info.hs b/src/IDE/Pane/Info.hs --- a/src/IDE/Pane/Info.hs +++ b/src/IDE/Pane/Info.hs @@ -34,7 +34,7 @@ import IDE.Core.State import Control.Event import IDE.Pane.SourceBuffer -import IDE.Pane.Callers +import IDE.Pane.References import IDE.FileUtils (openBrowser) import IDE.Metainfo.Provider (getIdentifierDescr) import Graphics.UI.Gtk.SourceView @@ -90,9 +90,9 @@ buttonBoxSetLayout bb ButtonboxSpread definitionB <- buttonNewWithLabel "Source" moduB <- buttonNewWithLabel "Modules" - usesB <- buttonNewWithLabel "Usage" + usesB <- buttonNewWithLabel "Refs" docuB <- buttonNewWithLabel "Docu" - searchB <- buttonNewWithLabel "Find" + searchB <- buttonNewWithLabel "Search" boxPackStartDefaults bb definitionB boxPackStartDefaults bb moduB boxPackStartDefaults bb usesB @@ -122,6 +122,16 @@ sourceBufferSetHighlightSyntax descriptionBuffer True widgetModifyFont descriptionView (Just font) + case sourceStyle prefs of + Nothing -> return () + Just str -> do + styleManager <- sourceStyleSchemeManagerNew + ids <- sourceStyleSchemeManagerGetSchemeIds styleManager + when (elem str ids) $ do + scheme <- sourceStyleSchemeManagerGetScheme styleManager str + sourceBufferSetStyleScheme descriptionBuffer scheme + + sw <- scrolledWindowNew Nothing Nothing containerAdd sw descriptionView scrolledWindowSetPolicy sw PolicyAutomatic PolicyAutomatic @@ -134,7 +144,7 @@ let info = IDEInfo ibox currentDescr' descriptionView definitionB `onClicked` (reflectIDE gotoSource ideR ) moduB `onClicked` (reflectIDE gotoModule' ideR ) - usesB `onClicked` (reflectIDE calledBy' ideR ) + usesB `onClicked` (reflectIDE referencedFrom' ideR ) searchB `onClicked` (do descr <- readIORef currentDescr' reflectIDE (do @@ -149,9 +159,11 @@ buf <- textViewGetBuffer descriptionView (l,r) <- textBufferGetSelectionBounds buf symbol <- textBufferGetText buf l r True - reflectIDE (triggerEvent ideR (SelectInfo symbol)) ideR + when (controlIsPressed e) + (reflectIDE (do + triggerEvent ideR (SelectInfo symbol) + return ()) ideR) return False) - notebookInsertOrdered nb ibox (paneName info) Nothing widgetShowAll ibox return (info,[]) @@ -175,12 +187,12 @@ Nothing -> return () Just info -> triggerEvent ideR (SelectIdent info) >> return () -calledBy' :: IDEAction -calledBy' = do +referencedFrom' :: IDEAction +referencedFrom' = do mbInfo <- getInfoCont case mbInfo of Nothing -> return () - Just info -> calledBy info >> return () + Just info -> referencedFrom info >> return () setSymbol :: String -> IDEAction setSymbol symbol = do diff --git a/src/IDE/Pane/Log.hs b/src/IDE/Pane/Log.hs --- a/src/IDE/Pane/Log.hs +++ b/src/IDE/Pane/Log.hs @@ -17,7 +17,7 @@ module IDE.Pane.Log ( IDELog(..) , LogView(..) -, LogAction(..) +, clearLog , LogState , LogTag(..) @@ -27,39 +27,17 @@ ) where import Data.Typeable (Typeable(..)) -import Text.ParserCombinators.Parsec import IDE.Core.State import Graphics.UI.Gtk import Graphics.UI.Gtk.Gdk.Events -import Graphics.UI.Editor.MakeEditor (buildEditor) import Control.Monad.Trans (liftIO) -import Graphics.UI.Editor.Basics (eventPaneName) -import Graphics.UI.Editor.Basics (GUIEventSelector(..)) -import Control.Event (registerEvent) -import Graphics.UI.Editor.Simple (okCancelFields) -import Graphics.UI.Editor.Parameters -import Text.ParserCombinators.Parsec.Language (haskellDef) -import Data.Char (isUpper) -import qualified Text.ParserCombinators.Parsec.Token as P -import Text.ParserCombinators.Parsec.Language (haskellStyle) -import Data.List (foldl',sort,nub) -import IDE.SourceCandy (getCandylessText) -import IDE.Pane.SourceBuffer (inActiveBufContext') -import IDE.Metainfo.Provider (getIdentifierDescr) -import Debug.Trace (trace) -import Data.List (nubBy) -import IDE.Pane.SourceBuffer (markErrorInSourceBuf) -import IDE.Pane.SourceBuffer (selectSourceBuf) -import Graphics.UI.Editor.MakeEditor (FieldDescription(..),mkField) -import Graphics.UI.Editor.Simple (staticListEditor) -import Data.Maybe (isNothing,isJust) -import Distribution.ModuleName(ModuleName) -import Distribution.Text(disp) -import Text.PrettyPrint (render) +import IDE.Pane.SourceBuffer (markErrorInSourceBuf,selectSourceBuf) +import Data.Maybe (isJust) import System.Process import System.IO import Prelude hiding (catch) import Control.Exception hiding (try) +import IDE.ImportTool (addAllImports,addImport,parseNotInScope) ------------------------------------------------------------------------------- -- -- * Interface @@ -79,16 +57,6 @@ deriving(Eq,Ord,Read,Show,Typeable) -class LogAction alpha where - clearLog :: alpha - addAllImports :: alpha - addOneImport :: alpha - -instance LogAction IDEAction where - clearLog = clearLog' - addAllImports = addAllImports' - addOneImport = addOneImport' - class Pane alpha beta => LogView alpha beta where getLog :: beta alpha appendLog :: alpha -> String -> LogTag -> IO Int @@ -204,7 +172,7 @@ theMenu <- menuNew item0 <- menuItemNewWithLabel "Add all imports" item0 `onActivateLeaf` do - reflectIDE addAllImports' ideR + reflectIDE addAllImports ideR menuShellAppend theMenu item0 case parseNotInScope (errDescription thisErr) of Nothing -> do @@ -212,7 +180,7 @@ Just _ -> do item1 <- menuItemNewWithLabel "Add import" item1 `onActivateLeaf` do - reflectIDE (addImport thisErr >> return()) ideR + reflectIDE (addImport thisErr [] >> return()) ideR menuShellAppend theMenu item1 menuPopup theMenu Nothing widgetShowAll theMenu @@ -286,370 +254,14 @@ return () -clearLog' :: IDEAction -clearLog' = do +clearLog :: IDEAction +clearLog = do log <- getLog buf <- liftIO$ textViewGetBuffer $textView log liftIO $textBufferSetText buf "" modifyIDE_ (\ide -> return (ide{errors = [], currentErr = Nothing})) ----------------------------------------------------------------------------- --- |* Import Wizard --- | Add all imports which gave error messages ... -addAllImports' :: IDEAction -addAllImports' = do - errors <- readIDE errors - mapM_ addImport [ y | (x,y) <- - nubBy (\ (p1,_) (p2,_) -> p1 == p2) - $ [(x,y) | (x,y) <- [((parseNotInScope . errDescription) e, e) | e <- errors]], - isJust x] - --- | Add import for current error ... -addOneImport' :: IDEAction -addOneImport' = do - errors' <- readIDE errors - currentErr' <- readIDE currentErr - case currentErr' of - Nothing -> do - ideMessage Normal $ "No error selected" - return () - Just i -> do - if 0 <= i && i < length errors' - then let error = errors' !! i - in addImport error >> return () - else error "Log>>addOneImport: Error out of range" - --- | Add one missing import -addImport :: ErrorSpec -> IDEM (Bool,Maybe ModuleName) -addImport error = - case parseNotInScope (errDescription error) of - Nothing -> trace "Dont parse as not in scope error" return (True,Nothing) - Just nis -> do - currentInfo' <- readIDE currentInfo - case currentInfo' of - Nothing -> trace "No current info" return (False,Nothing) - Just ((_,symbolTable1),(_,symbolTable2)) -> - case (getIdentifierDescr (id' nis) symbolTable1 symbolTable2) of - [] -> do - ideMessage Normal $ "Identifier " ++ (id' nis) ++ - " not found in imported packages" - return (True,Nothing) - descr : [] -> addImport' nis (filePath error) descr - list -> do - mbDescr <- liftIO $ selectModuleDialog list (id' nis) - case mbDescr of - Nothing -> return (False,Nothing) - Just descr -> addImport' nis (filePath error) descr - -addImport' :: NotInScopeParseResult -> FilePath -> Descr -> IDEM (Bool,Maybe ModuleName) -addImport' nis filePath descr = let - mbQ = mbQual' nis - id = id' nis - mod = case descr of - Descr _ _ m _ _ _ -> modu m - Reexported m _ -> modu m - importId = if isSub' nis - then ImportCoC (getRealId descr id) Nothing - else if isOp' nis - then ImportOp (id' nis) - else ImportId (id' nis) - importSpec = ImportSpec (render $disp mod) mbQ (Just ([importId],True)) 0 - in do - candy' <- readIDE candy - mbBuf <- selectSourceBuf filePath - case mbBuf of - Nothing -> return (True,Nothing) - Just buf -> do - inActiveBufContext' () $ \ _ gtkbuf _ _ -> do - ideMessage Normal $ "addImport " ++ show id ++ " from " ++ (render $ disp $ mod) - liftIO $ do - i1 <- textBufferGetStartIter gtkbuf - i2 <- textBufferGetEndIter gtkbuf - text <- getCandylessText candy' gtkbuf - let (importSpecs,lastImport) = getImportSpecs text - linesToModify = filter (\ is -> modid is == (render $ disp $ mod) - && mbQual is == mbQ - && not(isHiding (mbImpspec is))) importSpecs - case linesToModify of - [] -> let newSpec = importSpec - newLine = show newSpec ++ "\n" - lineSel = let bv = foldl' max 0 (map lineNr importSpecs) in - if bv == 0 - then (lastImport `max` 0) - else bv - in do - textIterSetLine i1 lineSel - textBufferInsert gtkbuf i1 newLine - (spec:t) -> let newSpec = spec{mbImpspec = - case mbImpspec spec of - Nothing -> Just ([importId],True) - Just (ids,b) -> Just (nub(importId:ids),b)} - newLine = show newSpec ++ "\n" - in do - textIterSetLine i1 (lineNr spec - 1) - textIterSetLine i2 (lineNr spec) - textBufferDelete gtkbuf i1 i2 - textBufferInsert gtkbuf i1 newLine - return (True,Just mod) - where - isHiding (Just (_,False)) = True - isHiding _ = False - -getRealId descr id = if isReexported descr - then getRealId (impDescr descr) id - else getReal (details' descr) - where - getReal (FieldDescr d) = descrName' d - getReal (ConstructorDescr d) = descrName' d - getReal (MethodDescr d) = descrName' d - getReal _ = id - --- |* The import data - -data NotInScopeParseResult = NotInScopeParseResult { - mbQual' :: Maybe String - , id' :: String - , isSub' :: Bool - , isOp' :: Bool} - deriving Eq - -data ImportSpec = ImportSpec - { modid :: String - , mbQual :: Maybe String - , mbImpspec :: Maybe ([ImportItem],Bool) - , lineNr :: Int} - -data ImportItem = - ImportId String - | ImportOp String - | ImportCoC String (Maybe [ImportSubItem]) - deriving Eq - -instance Show ImportItem where - show (ImportId str) = str - show (ImportOp str) = "(" ++ str ++ ")" - show (ImportCoC str Nothing) = str ++ "(..)" - show (ImportCoC str (Just [])) = str - show (ImportCoC str (Just l)) = str ++ "(" ++ showCoC l - where - showCoC [a] = show a ++ ")" - showCoC (a:b) = show a ++ "," ++ showCoC b - showCoC _ = error "Log>>instance ImportItem Show: Empty list" - - -data ImportSubItem = - ImportSubId String - | ImportSubOp String - deriving Eq - -instance Show ImportSubItem where - show (ImportSubId str) = str - show (ImportSubOp str) = "(" ++ str ++ ")" - -instance Show ImportSpec where - show (ImportSpec modid mbQual mbImpspec _) = "import " - ++ case mbQual of - Nothing -> "" - Just _ -> "qualified " - ++ modid - ++ case mbQual of - Nothing -> "" - Just str -> " as " ++ str ++ " " - ++ case mbImpspec of - Nothing -> "" - Just ([],True) -> "" - Just (l,True) -> " (" ++ showImportSpecs l - Just (l, False) -> " hiding (" ++ showImportSpecs l - where - showImportSpecs [a] = show a ++ ")" - showImportSpecs (a:b) = show a ++ "," ++ showImportSpecs b - showImportSpecs _ = error "Log>>showImportSpecs: Empty list" - - --- |* The error line parser - -lexer = P.makeTokenParser haskellStyle -lexeme = P.lexeme lexer -whiteSpace = P.whiteSpace lexer -symbol = P.symbol lexer -identifier = P.identifier lexer -comma = P.comma lexer -dot = P.dot lexer -integer = P.integer lexer -parens = P.parens lexer -operator = P.operator lexer - -parseNotInScope :: String -> (Maybe NotInScopeParseResult) -parseNotInScope str = - case parse scopeParser "" str of - Left e -> Nothing - Right r -> Just r - -scopeParser :: CharParser () NotInScopeParseResult -scopeParser = do - whiteSpace - symbol "Not in scope:" - isSub <- optionMaybe (try (choice [symbol "type constructor or class" - , symbol "data constructor"])) - symbol "`" - mbQual <- optionMaybe (try (do - q <- lexeme conid - dot - return q)) - id <- optionMaybe (try identifier) - case id of - Just id -> return (NotInScopeParseResult mbQual - (take (length id - 1) id) (isJust isSub) False) - Nothing -> do - op <- operator - symbol "'" - return (NotInScopeParseResult mbQual op (isJust isSub) True) - "scopeParser" - --- |* The import parser - -getImportSpecs :: String -> ([ImportSpec],Int) -getImportSpecs modSource = - case parse importSpecParser "" modSource of - Left e -> trace ("parse failed with " ++ show e) ([],0) - Right specs -> trace (show specs) specs - -importSpecParser :: CharParser () ([ImportSpec],Int) -importSpecParser = do - whiteSpace - skipHeader - lines <- sepBy (try parseImportLine) (many newline) - pos <- getPosition - skipMany anyChar - eof - return (lines, sourceLine pos - 2) - "importSpecParser" - -skipHeader :: CharParser () () -skipHeader =do - try (do - symbol "module" - manyTill anyChar (try (symbol "where")) - trace "with module header " (return ())) - <|> trace "no module header " (return ()) - "skipHeader" - -parseImportLine :: CharParser () ImportSpec -parseImportLine = do - symbol "import" - pos <- getPosition - isQualified <- optionMaybe (try (symbol "qualified")) - modid <- lexeme mident - whiteSpace - mbQName <- if isJust isQualified - then do - symbol "as" - qid <- identifier - return (Just qid) - else return Nothing - mbImpSpec <- optionMaybe - (try (do - mbHiding <- optionMaybe (try (symbol "hiding")) - idList <- parens (sepBy parseImportItem comma) - return (idList, isNothing mbHiding))) - whiteSpace - return (ImportSpec modid mbQName mbImpSpec (sourceLine pos)) - "parseImportLine" - -parseImportItem :: CharParser () ImportItem -parseImportItem = do - id <- optionMaybe (try identifier) - case id of - Just id -> if isUpper (head id) - then do - ccList <- optionMaybe (try parseSubList) - return (ImportCoC id Nothing) - else return (ImportId id) - Nothing -> do - op <- optionMaybe (try (parens operator)) - case op of - Just op -> return (ImportOp op) - Nothing -> do - pos <- getPosition - error $ "Can't parse import item " ++ show pos - "parseImportItem" - -parseSubList :: CharParser () (Maybe [ImportSubItem]) -parseSubList = do - all <- optionMaybe (try (symbol "(..)")) - case all of - Just _ -> return Nothing - Nothing -> do - list <- optionMaybe (try (parens (sepBy parseSubItem comma))) - case list of - Nothing -> return (Just []) - Just l -> return list - "parseSubList" - -parseSubItem :: CharParser () ImportSubItem -parseSubItem = do - id <- optionMaybe (try identifier) - case id of - Just id -> return (ImportSubId id) - Nothing -> do - op <- optionMaybe (try operator) - case op of - Just op -> return (ImportSubOp op) - Nothing -> do - pos <- getPosition - error $ "Can't parse sub import item " ++ show pos - "parseSubItem" - -mident = do - c <- P.identStart haskellDef - cs <- many (alphaNum <|> oneOf "_'.") - return (c:cs) - "midentifier" - -conid = do - c <- upper - cs <- many (alphaNum <|> oneOf "_'") - return (c:cs) - "conid" - --- |* The stupid little dialog - -moduleFields :: [String] -> String -> FieldDescription String -moduleFields list id = - mkField - (paraName <<<- ParaName ("From which module is " ++ id) - $ paraMultiSel <<<- ParaMultiSel False - $ emptyParams) - (\ a -> [a]) - (\ [a] b -> a) - (staticListEditor ((nub . sort) list)) - -selectModuleDialog :: [Descr] -> String -> IO (Maybe Descr) -selectModuleDialog list id = do - dia <- dialogNew - upper <- dialogGetUpper dia - lower <- dialogGetActionArea dia - (widget,_,ext,_) <- buildEditor (moduleFields - (map (render . disp . modu . descrModu') list) id) - ((render . disp . modu . descrModu') (head list)) - (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 ([]) - widgetDestroy dia - --find - case (resp,value) of - (ResponseOk,Just v) -> return (Just (head (filter (\e -> (render . disp . modu . descrModu') e == v) - list))) - _ -> trace ("cancel") return Nothing -- --------------------------------------------------------------------- -- ** Spawning external processes diff --git a/src/IDE/Pane/Modules.hs b/src/IDE/Pane/Modules.hs --- a/src/IDE/Pane/Modules.hs +++ b/src/IDE/Pane/Modules.hs @@ -28,7 +28,6 @@ ) where import Graphics.UI.Gtk hiding (get) -import qualified Graphics.UI.Gtk.ModelView as New import Graphics.UI.Gtk.Gdk.Events import Data.Maybe import Control.Monad.Reader @@ -56,9 +55,9 @@ 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 (forceJust,forceHead,split) +import MyMissing (forceHead) import IDE.Metainfo.Provider (rebuildActiveInfo) -import Debug.Trace (trace) +import qualified System.IO.UTF8 as UTF8 (writeFile) -- | A modules pane description @@ -67,23 +66,41 @@ data IDEModules = IDEModules { outer :: VBox , paned :: HPaned -, treeView :: New.TreeView -, treeStore :: New.TreeStore (String, [(ModuleDescr,PackageDescr)]) -, descrView :: New.TreeView -, descrStore :: New.TreeStore Descr +, treeView :: TreeView +, treeStore :: TreeStore (String, [(ModuleDescr,PackageDescr)]) +, descrView :: TreeView +, descrStore :: TreeStore Descr , localScopeB :: RadioButton , packageScopeB :: RadioButton -, worldScopeB :: RadioButton +, systemScopeB :: RadioButton , blacklistB :: CheckButton , oldSelection :: IORef SelectionState +, expanderState :: IORef ExpanderState } deriving Typeable data ModulesState = ModulesState Int (Scope,Bool) - (Maybe ModuleName, Maybe Symbol) + (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 @@ -99,15 +116,17 @@ instance RecoverablePane IDEModules ModulesState IDEM where saveState p = do - (IDEModules _ _ treeView treeStore descrView descrStore _ _ _ _ _) <- getModules + 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 treeStore - mbFacetSelection <- getSelectionDescr descrView descrStore + mbTreeSelection <- getSelectionTree (treeView m) (treeStore m) + mbFacetSelection <- getSelectionDescr (descrView m) (descrStore m) let mbs = (case mbTreeSelection of Nothing -> Nothing Just (_,[]) -> Nothing @@ -115,20 +134,21 @@ case mbFacetSelection of Nothing -> Nothing Just fw -> Just (descrName fw)) - return (Just (ModulesState i sc mbs)) - recoverState pp (ModulesState i sc@(scope,useBlacklist) se) = do + return (Just (ModulesState i sc mbs expander)) + recoverState pp (ModulesState i sc@(scope,useBlacklist) se exp) = do nb <- getNotebook pp initModules pp nb - mod@(IDEModules _ _ treeView treeStore descrView descrStore lb pb wb blb _) - <- getModules + mod <- getModules + liftIO $ writeIORef (expanderState mod) exp case scope of - Local -> liftIO $ toggleButtonSetActive lb True - Package -> liftIO $ toggleButtonSetActive pb True - System -> liftIO $ toggleButtonSetActive wb True - liftIO $ toggleButtonSetActive blb useBlacklist + 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 @@ -166,24 +186,24 @@ selectIdentifier' moduleName symbol = let nameArray = components moduleName in do - mods@(IDEModules _ _ treeView treeStore descrView descrStore _ _ _ _ _) <- getModules - mbTree <- liftIO $ treeStoreGetTreeSave treeStore [] + mods <- getModules + mbTree <- liftIO $ treeStoreGetTreeSave (treeStore mods) [] case treePathFromNameArray mbTree nameArray [] of Just treePath -> liftIO $ do - New.treeViewExpandToPath treeView treePath - sel <- New.treeViewGetSelection treeView - New.treeSelectionSelectPath sel treePath - col <- New.treeViewGetColumn treeView 0 - New.treeViewScrollToCell treeView treePath (fromJust col) (Just (0.3,0.3)) - mbFacetTree <- treeStoreGetTreeSave descrStore [] - selF <- New.treeViewGetSelection descrView + 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 - New.treeViewExpandToPath descrView path - New.treeSelectionSelectPath selF path - col <- New.treeViewGetColumn descrView 0 - New.treeViewScrollToCell descrView path (fromJust col) (Just (0.3,0.3)) + 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 () @@ -251,79 +271,79 @@ let forest = case currentInfo of Nothing -> [] Just pair -> subForest (buildModulesTree pair) - treeStore <- New.treeStoreNew forest - treeView <- New.treeViewNew - New.treeViewSetModel treeView treeStore - --New.treeViewSetRulesHint treeView True + treeStore <- treeStoreNew forest + treeView <- treeViewNew + treeViewSetModel treeView treeStore + --treeViewSetRulesHint treeView True - renderer0 <- New.cellRendererPixbufNew - set renderer0 [ New.cellPixbufStockId := "" ] + renderer0 <- cellRendererPixbufNew + set renderer0 [ cellPixbufStockId := "" ] - renderer <- New.cellRendererTextNew - col <- New.treeViewColumnNew - New.treeViewColumnSetTitle col "Modules" - New.treeViewColumnSetSizing col TreeViewColumnAutosize - New.treeViewColumnSetResizable col True - New.treeViewColumnSetReorderable col True - New.treeViewAppendColumn treeView col - New.cellLayoutPackStart col renderer0 False - New.cellLayoutPackStart col renderer True - New.cellLayoutSetAttributes col renderer treeStore - $ \row -> [ New.cellText := fst row] - New.cellLayoutSetAttributes col renderer0 treeStore + 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 -> [ - New.cellPixbufStockId := + cellPixbufStockId := if null (snd row) then "" else if isJust (mbSourcePathMD (fst (head (snd row)))) then "ide_source" else ""] - renderer2 <- New.cellRendererTextNew - col2 <- New.treeViewColumnNew - New.treeViewColumnSetTitle col2 "Packages" - New.treeViewColumnSetSizing col2 TreeViewColumnAutosize - New.treeViewColumnSetResizable col2 True - New.treeViewColumnSetReorderable col2 True - New.treeViewAppendColumn treeView col2 - New.cellLayoutPackStart col2 renderer2 True - New.cellLayoutSetAttributes col2 renderer2 treeStore - $ \row -> [ New.cellText := (concat . intersperse ", ") + 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)] - New.treeViewSetHeadersVisible treeView True - New.treeViewSetEnableSearch treeView True - New.treeViewSetSearchEqualFunc treeView (Just (treeViewSearch treeView treeStore)) + treeViewSetHeadersVisible treeView True + treeViewSetEnableSearch treeView True + treeViewSetSearchEqualFunc treeView (Just (treeViewSearch treeView treeStore)) -- Facet view - descrView <- New.treeViewNew - descrStore <- New.treeStoreNew [] - New.treeViewSetModel descrView descrStore - renderer30 <- New.cellRendererPixbufNew - renderer31 <- New.cellRendererPixbufNew - renderer3 <- New.cellRendererTextNew - col <- New.treeViewColumnNew - New.treeViewColumnSetTitle col "Interface" - --New.treeViewColumnSetSizing col TreeViewColumnAutosize - New.treeViewAppendColumn descrView col - New.cellLayoutPackStart col renderer30 False - New.cellLayoutPackStart col renderer31 False - New.cellLayoutPackStart col renderer3 True - New.cellLayoutSetAttributes col renderer3 descrStore - $ \row -> [ New.cellText := descrTreeText row] - New.cellLayoutSetAttributes col renderer30 descrStore + 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 -> [ - New.cellPixbufStockId := stockIdFromType (descrIdType row)] - New.cellLayoutSetAttributes col renderer31 descrStore + cellPixbufStockId := stockIdFromType (descrIdType row)] + cellLayoutSetAttributes col renderer31 descrStore $ \row -> [ - New.cellPixbufStockId := if isReexported row + cellPixbufStockId := if isReexported row then "ide_reexported" else if isJust (mbLocation row) then "ide_source" else ""] - New.treeViewSetHeadersVisible descrView True - New.treeViewSetEnableSearch descrView True - New.treeViewSetSearchEqualFunc descrView (Just (descrViewSearch descrView descrStore)) + treeViewSetHeadersVisible descrView True + treeViewSetEnableSearch descrView True + treeViewSetSearchEqualFunc descrView (Just (descrViewSearch descrView descrStore)) pane' <- hPanedNew sw <- scrolledWindowNew Nothing Nothing containerAdd sw treeView @@ -351,14 +371,15 @@ 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 + rb1 rb2 rb3 cb oldState expanderState notebookInsertOrdered nb boxOuter (paneName modules) Nothing widgetShowAll boxOuter - cid3 <- treeView `New.onRowActivated` + cid3 <- treeView `onRowActivated` (\ treePath _ -> do - New.treeViewExpandRow treeView treePath False + treeViewExpandRow treeView treePath False return ()) cid1 <- treeView `afterFocusIn` (\_ -> do reflectIDE (makeActive modules) ideR; return True) @@ -370,13 +391,13 @@ rb2 `onToggled` (reflectIDE scopeSelection ideR) rb3 `onToggled` (reflectIDE scopeSelection ideR) cb `onToggled` (reflectIDE scopeSelection ideR) - sel <- New.treeViewGetSelection treeView - sel `New.onSelectionChanged` do + sel <- treeViewGetSelection treeView + sel `onSelectionChanged` do fillFacets treeView treeStore descrView descrStore reflectIDE recordSelHistory ideR return () - sel2 <- New.treeViewGetSelection descrView - sel2 `New.onSelectionChanged` do + sel2 <- treeViewGetSelection descrView + sel2 `onSelectionChanged` do fillInfo descrView descrStore ideR reflectIDE recordSelHistory ideR return () @@ -385,19 +406,19 @@ liftIO $widgetGrabFocus (paned buf) treeViewSearch :: TreeView - -> New.TreeStore (String, [(ModuleDescr,PackageDescr)]) + -> TreeStore (String, [(ModuleDescr,PackageDescr)]) -> String - -> New.TreeIter + -> TreeIter -> IO Bool treeViewSearch treeView treeStore string iter = do - path <- New.treeModelGetPath treeStore iter - val <- New.treeStoreGetValue treeStore path + path <- treeModelGetPath treeStore iter + val <- treeStoreGetValue treeStore path mbTree <- treeStoreGetTreeSave treeStore path - exp <- New.treeViewRowExpanded treeView 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 - New.treeViewExpandRow treeView path False + treeViewExpandRow treeView path False return () let str2 = case snd val of [] -> fst val @@ -416,19 +437,19 @@ $ concatMap flatten (subForest tree) descrViewSearch :: TreeView - -> New.TreeStore Descr + -> TreeStore Descr -> String - -> New.TreeIter + -> TreeIter -> IO Bool descrViewSearch descrView descrStore string iter = do - path <- New.treeModelGetPath descrStore iter - val <- New.treeStoreGetValue descrStore path - tree <- New.treeStoreGetTree descrStore path - exp <- New.treeViewRowExpanded descrView path + 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 - New.treeViewExpandRow descrView path False + treeViewExpandRow descrView path False return () return (isInfixOf (map toLower string) (map toLower (descrTreeText val))) @@ -439,10 +460,10 @@ isInfixOf (map toLower str) (map toLower (descrTreeText val))) $ concatMap flatten (subForest tree) -fillFacets :: New.TreeView - -> New.TreeStore (String, [(ModuleDescr,PackageDescr)]) - -> New.TreeView - -> New.TreeStore Descr +fillFacets :: TreeView + -> TreeStore (String, [(ModuleDescr,PackageDescr)]) + -> TreeView + -> TreeStore Descr -> IO () fillFacets treeView treeStore descrView descrStore = do sel <- getSelectionTree treeView treeStore @@ -451,54 +472,54 @@ -> case snd val of ((mod,package):_) -> let forest = buildFacetForrest mod in do - emptyModel <- New.treeStoreNew [] - New.treeViewSetModel descrView emptyModel - New.treeStoreClear descrStore - mapM_ (\(e,i) -> New.treeStoreInsertTree descrStore [] i e) + emptyModel <- treeStoreNew [] + treeViewSetModel descrView emptyModel + treeStoreClear descrStore + mapM_ (\(e,i) -> treeStoreInsertTree descrStore [] i e) $ zip forest [0 .. length forest] - New.treeViewSetModel descrView descrStore - New.treeViewSetEnableSearch descrView True - New.treeViewSetSearchEqualFunc descrView (Just (descrViewSearch descrView descrStore)) - [] -> New.treeStoreClear descrStore + treeViewSetModel descrView descrStore + treeViewSetEnableSearch descrView True + treeViewSetSearchEqualFunc descrView (Just (descrViewSearch descrView descrStore)) + [] -> treeStoreClear descrStore Nothing - -> New.treeStoreClear descrStore + -> treeStoreClear descrStore -getSelectionTree :: New.TreeView - -> New.TreeStore (String, [(ModuleDescr,PackageDescr)]) +getSelectionTree :: TreeView + -> TreeStore (String, [(ModuleDescr,PackageDescr)]) -> IO (Maybe (String, [(ModuleDescr,PackageDescr)])) getSelectionTree treeView treeStore = do - treeSelection <- New.treeViewGetSelection treeView - paths <- New.treeSelectionGetSelectedRows treeSelection + treeSelection <- treeViewGetSelection treeView + paths <- treeSelectionGetSelectedRows treeSelection case paths of [] -> return Nothing a:r -> do - val <- New.treeStoreGetValue treeStore a + val <- treeStoreGetValue treeStore a return (Just val) -getSelectionDescr :: New.TreeView - -> New.TreeStore Descr +getSelectionDescr :: TreeView + -> TreeStore Descr -> IO (Maybe Descr) getSelectionDescr treeView treeStore = do - treeSelection <- New.treeViewGetSelection treeView - paths <- New.treeSelectionGetSelectedRows treeSelection + treeSelection <- treeViewGetSelection treeView + paths <- treeSelectionGetSelectedRows treeSelection case paths of a:r -> do - val <- New.treeStoreGetValue treeStore a + val <- treeStoreGetValue treeStore a return (Just val) _ -> return Nothing -fillInfo :: New.TreeView - -> New.TreeStore Descr +fillInfo :: TreeView + -> TreeStore Descr -> IDERef -> IO () fillInfo treeView lst ideR = do - treeSelection <- New.treeViewGetSelection treeView - paths <- New.treeSelectionGetSelectedRows treeSelection + treeSelection <- treeViewGetSelection treeView + paths <- treeSelectionGetSelectedRows treeSelection case paths of [] -> return () [a] -> do - descr <- New.treeStoreGetValue lst a + descr <- treeStoreGetValue lst a reflectIDE (setInfo descr) ideR return () _ -> return () @@ -513,7 +534,7 @@ fillModulesList :: (Scope,Bool) -> IDEAction fillModulesList (scope,useBlacklist) = do - (IDEModules _ _ treeView treeStore _ _ _ _ _ _ _) <- getModules + mods <- getModules prefs <- readIDE prefs currentInfo' <- readIDE currentInfo accessibleInfo' <- readIDE accessibleInfo @@ -527,12 +548,12 @@ (Node _ li) = buildModulesTree ((Map.empty,Map.empty),p2) in liftIO $ do - New.treeStoreClear treeStore - mapM_ (\(e,i) -> New.treeStoreInsertTree treeStore [] i e) + treeStoreClear (treeStore mods) + mapM_ (\(e,i) -> treeStoreInsertTree (treeStore mods) [] i e) $ zip li [0 .. length li] _ -> liftIO $ do - New.treeStoreClear treeStore - New.treeStoreInsertTree treeStore [] 0 (Node ("",[]) []) + 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) @@ -545,14 +566,15 @@ else p' (Node _ li) = buildModulesTree (l',p2) in liftIO $ do - emptyModel <- New.treeStoreNew [] - New.treeViewSetModel treeView emptyModel - New.treeStoreClear treeStore - mapM_ (\(e,i) -> New.treeStoreInsertTree treeStore [] i e) + emptyModel <- treeStoreNew [] + treeViewSetModel (treeView mods) emptyModel + treeStoreClear (treeStore mods) + mapM_ (\(e,i) -> treeStoreInsertTree (treeStore mods) [] i e) $ zip li [0 .. length li] - New.treeViewSetModel treeView treeStore - New.treeViewSetEnableSearch treeView True - New.treeViewSetSearchEqualFunc treeView (Just (treeViewSearch treeView treeStore)) + treeViewSetModel (treeView mods) (treeStore mods) + treeViewSetEnableSearch (treeView mods) True + treeViewSetSearchEqualFunc (treeView mods) + (Just (treeViewSearch (treeView mods) (treeStore mods))) filterBlacklist :: [Dependency] -> PackageDescr -> Bool @@ -584,7 +606,8 @@ let (instances,other) = partition (\id -> case details id of InstanceDescr _ -> True _ -> False) - $ idDescriptionsMD modDescr + $ take 2000 $ idDescriptionsMD modDescr + -- TODO: Patch for toxioc TypeLevel package with 28000 aliases forestWithoutInstances = map buildFacet other (forest2,orphaned) = foldl' addInstances (forestWithoutInstances,[]) instances @@ -708,8 +731,8 @@ sortTree (Node l forest) = Node l (sort (map sortTree forest)) treeViewPopup :: IDERef - -> New.TreeStore (String, [(ModuleDescr,PackageDescr)]) - -> New.TreeView + -> TreeStore (String, [(ModuleDescr,PackageDescr)]) + -> TreeView -> Event -> IO (Bool) treeViewPopup ideR store treeView (Button _ click _ _ _ _ button _ _) = do @@ -732,9 +755,9 @@ item3 <- menuItemNewWithLabel "Collapse here" item3 `onActivateLeaf` (collapseHere treeView) item4 <- menuItemNewWithLabel "Expand all" - item4 `onActivateLeaf` (New.treeViewExpandAll treeView) + item4 `onActivateLeaf` (treeViewExpandAll treeView) item5 <- menuItemNewWithLabel "Collapse all" - item5 `onActivateLeaf` (New.treeViewCollapseAll treeView) + item5 `onActivateLeaf` (treeViewCollapseAll treeView) sep2 <- separatorMenuItemNew item6 <- menuItemNewWithLabel "Add module" item6 `onActivateLeaf` (reflectIDE (addModule treeView store) ideR) @@ -759,8 +782,8 @@ treeViewPopup _ _ _ _ = throwIDE "treeViewPopup wrong event type" descrViewPopup :: IDERef - -> New.TreeStore Descr - -> New.TreeView + -> TreeStore Descr + -> TreeView -> Event -> IO (Bool) descrViewPopup ideR store descrView (Button _ click _ _ _ _ button _ _) = do @@ -792,23 +815,21 @@ setScope :: (Scope,Bool) -> IDEAction setScope (sc,bl) = do - (IDEModules _ _ treeView treeStore descrView descrStore localScopeB - packageScopeB worldScopeB blacklistB _) <- getModules + mods <- getModules case sc of - Local -> liftIO $ toggleButtonSetActive localScopeB True - Package -> liftIO $ toggleButtonSetActive packageScopeB True - System -> liftIO $ toggleButtonSetActive worldScopeB True - liftIO $ toggleButtonSetActive blacklistB bl + 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 - (IDEModules _ _ treeView treeStore descrView descrStore localScopeB - packageScopeB worldScopeB blacklistB _) <- getModules - rb1s <- liftIO $ toggleButtonGetActive localScopeB - rb2s <- liftIO $ toggleButtonGetActive packageScopeB - rb3s <- liftIO $ toggleButtonGetActive worldScopeB - cbs <- liftIO $ toggleButtonGetActive blacklistB + 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 @@ -823,14 +844,14 @@ selectScope :: (Scope,Bool) -> IDEAction selectScope (sc,bl) = do - mods@(IDEModules _ _ treeView treeStore descrView descrStore _ _ _ _ _) - <- getModules - mbTreeSelection <- liftIO $ getSelectionTree treeView treeStore - mbDescrSelection <- liftIO $ getSelectionDescr descrView descrStore + recordExpanderState + mods <- getModules + mbTreeSelection <- liftIO $ getSelectionTree (treeView mods) (treeStore mods) + mbDescrSelection <- liftIO $ getSelectionDescr (descrView mods) (descrStore mods) - ts <- liftIO $ New.treeViewGetSelection treeView + ts <- liftIO $ treeViewGetSelection (treeView mods) withoutRecordingDo $ do - liftIO $ New.treeSelectionUnselectAll ts + liftIO $ treeSelectionUnselectAll ts fillModulesList (sc,bl) let mbs = (case mbTreeSelection of Nothing -> Nothing @@ -841,44 +862,44 @@ Just fw -> Just (descrName fw)) selectNames mbs recordScopeHistory + applyExpanderState liftIO $ bringPaneToFront mods selectNames :: (Maybe ModuleName, Maybe Symbol) -> IDEAction selectNames (mbModuleName, mbIdName) = do - (IDEModules _ _ treeView treeStore descrView descrStore _ _ _ _ _) - <- getModules + mods <- getModules case mbModuleName of Nothing -> liftIO $ do - sel <- New.treeViewGetSelection treeView - New.treeSelectionUnselectAll sel - selF <- New.treeViewGetSelection descrView - New.treeSelectionUnselectAll selF + sel <- treeViewGetSelection (treeView mods) + treeSelectionUnselectAll sel + selF <- treeViewGetSelection (descrView mods) + treeSelectionUnselectAll selF Just moduleName -> let nameArray = components moduleName in do - mbTree <- liftIO $ treeStoreGetTreeSave treeStore [] + mbTree <- liftIO $ treeStoreGetTreeSave (treeStore mods) [] case treePathFromNameArray mbTree nameArray [] of Nothing -> return () Just treePath -> liftIO $ do - New.treeViewExpandToPath treeView treePath - sel <- New.treeViewGetSelection treeView - New.treeSelectionSelectPath sel treePath - col <- New.treeViewGetColumn treeView 0 - New.treeViewScrollToCell treeView treePath (fromJust col) + 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 <- New.treeViewGetSelection descrView - New.treeSelectionUnselectAll selF + selF <- treeViewGetSelection (descrView mods) + treeSelectionUnselectAll selF Just symbol -> do - mbDescrTree <- treeStoreGetTreeSave descrStore [] - selF <- New.treeViewGetSelection descrView + mbDescrTree <- treeStoreGetTreeSave (descrStore mods) [] + selF <- treeViewGetSelection (descrView mods) case findPathFor symbol mbDescrTree of Nothing -> sysMessage Normal "no path found" Just path -> do - New.treeSelectionSelectPath selF path - col <- New.treeViewGetColumn descrView 0 - New.treeViewScrollToCell descrView path (fromJust col) + treeSelectionSelectPath selF path + col <- treeViewGetColumn (descrView mods) 0 + treeViewScrollToCell (descrView mods) path (fromJust col) (Just (0.3,0.3)) reloadKeepSelection :: IDEAction @@ -886,13 +907,14 @@ mbMod <- getPane case mbMod of Nothing -> return () - Just mods@(IDEModules _ _ treeView treeStore descrView descrStore _ _ _ _ _) + Just mods -> do - mbTreeSelection <- liftIO $ getSelectionTree treeView treeStore - mbDescrSelection <- liftIO $ getSelectionDescr descrView descrStore + mbTreeSelection <- liftIO $ getSelectionTree (treeView mods) (treeStore mods) + mbDescrSelection <- liftIO $ getSelectionDescr (descrView mods) (descrStore mods) sc <- getScope + recordExpanderState fillModulesList sc - liftIO $ New.treeStoreClear descrStore + liftIO $ treeStoreClear (descrStore mods) let mbs = (case mbTreeSelection of Nothing -> Nothing Just (_,[]) -> Nothing @@ -900,12 +922,14 @@ case mbDescrSelection of Nothing -> Nothing Just fw -> Just (descrName fw)) + applyExpanderState selectNames mbs -treeStoreGetTreeSave :: New.TreeStore a -> TreePath -> IO (Maybe (Tree a)) + +treeStoreGetTreeSave :: TreeStore a -> TreePath -> IO (Maybe (Tree a)) treeStoreGetTreeSave treeStore treePath = catch (do - res <- New.treeStoreGetTree treeStore treePath + res <- treeStoreGetTree treeStore treePath return (Just res)) (\ (_ :: SomeException) -> return Nothing) expandHere :: TreeView -> IO () @@ -944,29 +968,24 @@ case mbResp of Nothing -> return () Just (AddModule modPath srcPath isExposed) -> - let splitter = split '.' modPath - (modPaths,[modName])= splitAt (length splitter - 1) splitter - targetPath = foldl' () (rootPath srcPath) modPaths - targetFile = targetPath (modName ++ ".hs") - in do - liftIO $ createDirectoryIfMissing True targetPath - alreadyExists <- liftIO $ doesFileExist targetFile - if alreadyExists - then ideMessage Normal "File already exists" - else do - template <- liftIO $ getModuleTemplate pd modName - liftIO $ writeFile targetFile template - addModuleToPackageDescr - (forceJust (simpleParse modPath) - ("Modules>>addModule Can't parse module name " ++ modPath)) - isExposed - packageConfig - rebuildActiveInfo - trace ("now openening " ++ targetFile) $ return () - fileOpenThis targetFile + 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 +-- Yet another stupid little dialog data AddModule = AddModule {moduleName :: String, sourceRoot :: FilePath, isExposed :: Bool} @@ -1017,15 +1036,72 @@ (\ a b -> b{isExposed = a}) boolEditor] --- * GUI History +-- * Expander State -data SelectionState = SelectionState { - moduleS' :: Maybe ModuleName -, facetS' :: Maybe String -, scope' :: Scope -, blacklist' :: Bool} - deriving (Eq,Ord,Show) +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 @@ -1066,13 +1142,12 @@ replayScopeHistory :: Scope -> Bool -> IDEAction replayScopeHistory sc bl = do - mods@(IDEModules _ _ _ _ _ _ localScopeB packageScopeB worldScopeB blacklistB _) - <- getModules + mods <- getModules liftIO $ do - toggleButtonSetActive blacklistB bl - toggleButtonSetActive localScopeB (sc == Local) - toggleButtonSetActive packageScopeB (sc == Package) - toggleButtonSetActive worldScopeB (sc == System) + 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}) diff --git a/src/IDE/Pane/PackageEditor.hs b/src/IDE/Pane/PackageEditor.hs --- a/src/IDE/Pane/PackageEditor.hs +++ b/src/IDE/Pane/PackageEditor.hs @@ -45,7 +45,6 @@ import Debug.Trace (trace) import qualified Distribution.InstalledPackageInfo as IPI (package) import Graphics.UI.Editor.Composite (maybeEditor,pairEditor,ColumnDescr(..),multisetEditor) -import qualified Graphics.UI.Gtk as New (cellText) import Distribution.Text (simpleParse,display) import MyMissing import Graphics.UI.Editor.Parameters (Parameter(..),paraPack,Direction(..),paraDirection,paraMinSize,paraShadow,paraSynopsis,(<<<-),emptyParams,paraName,getParameterPrim) @@ -616,8 +615,8 @@ (options . (\a -> a !! i) . bis) (\ a b -> b{bis = update (bis b) i (\bi -> bi{options = a})}) (multisetEditor - (ColumnDescr True [("Compiler Flavor",\(cv,_) -> [New.cellText := show cv]) - ,("Options",\(_,op) -> [New.cellText := concatMap (\s -> ' ' : s) op])]) + (ColumnDescr True [("Compiler Flavor",\(cv,_) -> [cellText := show cv]) + ,("Options",\(_,op) -> [cellText := concatMap (\s -> ' ' : s) op])]) ((pairEditor (compilerFlavorEditor,emptyParams) (stringsEditor (const True),emptyParams)), diff --git a/src/IDE/Pane/PackageFlags.hs b/src/IDE/Pane/PackageFlags.hs --- a/src/IDE/Pane/PackageFlags.hs +++ b/src/IDE/Pane/PackageFlags.hs @@ -249,7 +249,7 @@ widgetShowAll vb return (flagsPane,[]) addPaneAdmin buf [] panePath - liftIO $widgetGrabFocus (flagsBox buf) + liftIO $ widgetGrabFocus (flagsBox buf) diff --git a/src/IDE/Pane/References.hs b/src/IDE/Pane/References.hs new file mode 100644 --- /dev/null +++ b/src/IDE/Pane/References.hs @@ -0,0 +1,315 @@ +{-# OPTIONS_GHC -XDeriveDataTypeable -XMultiParamTypeClasses -XTypeSynonymInstances #-} +----------------------------------------------------------------------------- +-- +-- Module : IDE.Pane.References +-- Copyright : (c) Juergen Nicklisch-Franken (aka Jutaro) +-- License : GNU-GPL +-- +-- Maintainer : Juergen Nicklisch-Franken +-- Stability : experimental +-- Portability : portable +-- +-- | The pane of the ide where references to an identifier are presented +-- +------------------------------------------------------------------------------- + +module IDE.Pane.References ( + IDE(..) +, ReferencesState +, referencedFrom +, showReferences +) where + +import Graphics.UI.Gtk hiding (get) +import IDE.Find (focusFindEntry,showFindbar,setFindState,entryStr, getFindState, editFind) +import IDE.Pane.SourceBuffer (selectSourceBuf) +import Graphics.UI.Gtk.Gdk.Events +import Data.IORef (newIORef,writeIORef,readIORef,IORef(..)) +import Data.Maybe +import Control.Monad.Reader +import qualified Data.Map as Map +import qualified Data.Set as Set +import Data.List +import Data.Typeable +import Distribution.ModuleName(ModuleName) +import Distribution.Text +import Text.PrettyPrint (render) +import IDE.Core.State + + +-- | A References pane description +-- + +data IDEReferences = IDEReferences { + scrolledView :: ScrolledWindow +, treeViewC :: TreeView +, referencesDescr :: IORef (Maybe Descr) +, referencesStore :: ListStore (ModuleDescr,Symbol) +, refScopeRef :: IORef Scope +, referencesEntry :: Entry +, topBox :: VBox +} deriving Typeable + +data ReferencesState = ReferencesState { + refTo :: Maybe Descr +, refScope :: Scope} + deriving(Eq,Ord,Read,Show,Typeable) + + +instance IDEObject IDEReferences + +instance Pane IDEReferences IDEM + where + primPaneName _ = "References" + getAddedIndex _ = 0 + getTopWidget = castToWidget . topBox + paneId b = "*References" + makeActive p = activatePane p [] + close = closePane + + +-- | We don't recover this pane +instance RecoverablePane IDEReferences ReferencesState IDEM where + saveState p = do + mbDescr <- liftIO $ readIORef (referencesDescr p) + scope <- liftIO $ readIORef (refScopeRef p) + return (Just (ReferencesState mbDescr scope)) + recoverState pp (ReferencesState mbDescr scope) = do + nb <- getNotebook pp + initReferences pp nb (Just scope) + when (isJust mbDescr) (referencedFrom (fromJust mbDescr)) + +showReferences :: IDEAction +showReferences = do + m <- getReferences + liftIO $ bringPaneToFront m + liftIO $ widgetGrabFocus (treeViewC m) + + +-- | Open a pane with the references of this identifier +referencedFrom :: Descr -> IDEAction +referencedFrom idDescr = do + references <- getReferences + scope <- liftIO $ getScope references + mbCurrentInfo <- readIDE currentInfo + mbAccessibleInfo <- readIDE accessibleInfo + packages <- case scope of + System -> case mbAccessibleInfo of + Nothing -> return [] + Just scope -> return ((Map.elems . fst) scope) + Package -> case mbCurrentInfo of + Nothing -> return [] + Just currentInfo -> return ((Map.elems . fst . fst) currentInfo + ++ (Map.elems . fst . snd) currentInfo) + Local -> case mbCurrentInfo of + Nothing -> return [] + Just currentInfo -> return ((Map.elems . fst . fst) currentInfo) + let modulesList = modulesForCallerFromPackages packages (descrName idDescr, modu $ descrModu idDescr) + liftIO $ do + writeIORef (referencesDescr references) (Just idDescr) + listStoreClear (referencesStore references) + mapM_ (listStoreAppend (referencesStore references)) + $ sort $ zip modulesList (repeat (descrName idDescr)) + entrySetText (referencesEntry references) + $ descrName idDescr ++ + " << " ++ showPackModule (descrModu idDescr) + bringPaneToFront references + +modulesForCallerFromPackages :: [PackageDescr] -> (Symbol,ModuleName) -> [ModuleDescr] +modulesForCallerFromPackages [] _ = [] +modulesForCallerFromPackages (p :rest) (sym,mod) = + (filter (\ md -> case mod `Map.lookup` (referencesMD md) of + Nothing -> False + Just syms -> sym `Set.member` syms) (exposedModulesPD p)) + ++ modulesForCallerFromPackages rest (sym,mod) + +getReferences :: IDEM IDEReferences +getReferences = do + mbMod <- getPane + case mbMod of + Nothing -> do + prefs <- readIDE prefs + layout <- readIDE layout + let pp = getStandardPanePath (logPanePath prefs) layout + nb <- getNotebook pp + initReferences pp nb Nothing + mbMod <- getPane + case mbMod of + Nothing -> throwIDE "Can't init references" + Just m -> return m + Just m -> return m + +scopeSelection :: Scope -> IDEAction +scopeSelection scope = do + refs <- getReferences + liftIO $ writeIORef (refScopeRef refs) scope + mbDescr <- liftIO $ readIORef (referencesDescr refs) + case mbDescr of + Nothing -> return () + Just descr -> referencedFrom descr + +getScope :: IDEReferences -> IO Scope +getScope refs = readIORef (refScopeRef refs) + +initReferences :: PanePath -> Notebook -> Maybe Scope -> IDEAction +initReferences panePath nb mbScope = do + let scope = case mbScope of + Just s -> s + Nothing -> Package + prefs <- readIDE prefs + currentInfo <- readIDE currentInfo + (buf,cids) <- reifyIDE $ \ideR -> do + scopebox <- hBoxNew True 2 + rb1 <- radioButtonNewWithLabel "Local" + rb2 <- radioButtonNewWithLabelFromWidget rb1 "Package" + rb3 <- radioButtonNewWithLabelFromWidget rb1 "System" + toggleButtonSetActive + (case scope of + Local -> rb1 + Package -> rb2 + System -> rb3) True + boxPackStart scopebox rb1 PackNatural 2 + boxPackStart scopebox rb2 PackNatural 2 + boxPackEnd scopebox rb3 PackNatural 2 + + listStore <- listStoreNew [] + treeView <- treeViewNew + treeViewSetModel treeView listStore + + renderer0 <- cellRendererPixbufNew + set renderer0 [ cellPixbufStockId := stockYes ] + + 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 listStore + $ \row -> [ cellText := render $ disp $ modu $ moduleIdMD $ fst row] + cellLayoutSetAttributes col renderer0 listStore + $ \row -> [cellPixbufStockId := + if isJust (mbSourcePathMD $ fst row) + then stockJumpTo + else stockYes] + + renderer2 <- cellRendererTextNew + col2 <- treeViewColumnNew + treeViewColumnSetTitle col2 "Packages" + treeViewColumnSetSizing col2 TreeViewColumnAutosize + treeViewColumnSetResizable col True + treeViewColumnSetReorderable col2 True + treeViewAppendColumn treeView col2 + cellLayoutPackStart col2 renderer2 True + cellLayoutSetAttributes col2 renderer2 listStore + $ \row -> [ cellText := render $ disp $ pack $ moduleIdMD $ fst row] + + treeViewSetHeadersVisible treeView True + sel <- treeViewGetSelection treeView + treeSelectionSetMode sel SelectionSingle + + sw <- scrolledWindowNew Nothing Nothing + containerAdd sw treeView + scrolledWindowSetPolicy sw PolicyAutomatic PolicyAutomatic + entry <- entryNew + set entry [ entryEditable := False ] + box <- vBoxNew False 2 + boxPackStart box scopebox PackNatural 0 + boxPackStart box entry PackNatural 0 + boxPackEnd box sw PackGrow 0 + referencesDescr' <- newIORef Nothing + scope <- newIORef (case mbScope of + Just s -> s + Nothing -> Package) + let references = IDEReferences sw treeView referencesDescr' listStore scope entry box + notebookInsertOrdered nb box (paneName references) Nothing + widgetShowAll box + cid1 <- treeView `afterFocusIn` + (\_ -> do reflectIDE (makeActive references) ideR ; return True) + treeView `onButtonPress` (treeViewPopup ideR references) + rb1 `onToggled` (reflectIDE (scopeSelection Local) ideR ) + rb2 `onToggled` (reflectIDE (scopeSelection Package) ideR ) + rb3 `onToggled` (reflectIDE (scopeSelection System) ideR ) + + return (references,[ConnectC cid1]) + addPaneAdmin buf cids panePath + liftIO $widgetGrabFocus (scrolledView buf) + + +getSelectionTree :: TreeView + -> ListStore (ModuleDescr,Symbol) + -> IO (Maybe (ModuleDescr,Symbol)) +getSelectionTree treeView listStore = do + treeSelection <- treeViewGetSelection treeView + rows <- treeSelectionGetSelectedRows treeSelection + case rows of + [[n]] -> do + val <- listStoreGetValue listStore n + return (Just val) + _ -> return Nothing + +treeViewPopup :: IDERef + -> IDEReferences + -> Event + -> IO (Bool) +treeViewPopup ideR references (Button _ click _ _ _ _ button _ _) = do + if button == RightButton + then do + theMenu <- menuNew + item1 <- menuItemNewWithLabel "Edit" + item1 `onActivateLeaf` do + sel <- getSelectionTree (treeViewC references) (referencesStore references) + case sel of + Just (m,_) -> case mbSourcePathMD m of + Nothing -> return () + Just fp -> do + text <- entryGetText (referencesEntry references) + case words text of + (hd : tl) -> do + reflectIDE (selectText fp hd) ideR + return () + _ -> return () + otherwise -> return () + menuShellAppend theMenu item1 + menuPopup theMenu Nothing + widgetShowAll theMenu + return True + else if button == LeftButton && click == DoubleClick + then do sel <- getSelectionTree (treeViewC references) + (referencesStore references) + case sel of + Just (m,_) + -> case mbSourcePathMD m of + Nothing -> return False + Just fp -> do + text <- entryGetText (referencesEntry references) + case words text of + (hd : tl) -> do + reflectIDE (selectText fp hd) ideR + return True + _ -> return False + otherwise -> return False + else return False +treeViewPopup _ _ _ = throwIDE "treeViewPopup wrong event type" + +selectText :: FilePath -> String -> IDEM Bool +selectText fp text = do + res <- selectSourceBuf fp + fs <- getFindState + case res of + Nothing -> return False + Just _ -> do + setFindState fs {entryStr = text} + showFindbar + focusFindEntry + reifyIDE $ \ideR -> do + idleAdd (do + reflectIDE (editFind True True True text "" Forward) ideR + return False) + priorityDefaultIdle + return True + + diff --git a/src/IDE/Pane/Search.hs b/src/IDE/Pane/Search.hs --- a/src/IDE/Pane/Search.hs +++ b/src/IDE/Pane/Search.hs @@ -23,7 +23,6 @@ ) where import Graphics.UI.Gtk hiding (get) -import qualified Graphics.UI.Gtk.ModelView as New import Graphics.UI.Gtk.Gdk.Events import Data.IORef (newIORef) import Data.IORef (writeIORef,readIORef,IORef(..)) @@ -42,8 +41,8 @@ data IDESearch = IDESearch { scrolledView :: ScrolledWindow -, treeView :: New.TreeView -, searchStore :: New.ListStore Descr +, treeView :: TreeView +, searchStore :: ListStore Descr , searchScopeRef :: IORef Scope , searchModeRef :: IORef SearchMode , topBox :: VBox @@ -138,61 +137,61 @@ boxPackStart modebox mb3 PackNatural 2 boxPackEnd modebox mb4 PackNatural 2 - listStore <- New.listStoreNew [] - treeView <- New.treeViewNew - New.treeViewSetModel treeView listStore + listStore <- listStoreNew [] + treeView <- treeViewNew + treeViewSetModel treeView listStore - renderer3 <- New.cellRendererTextNew - renderer30 <- New.cellRendererPixbufNew - col3 <- New.treeViewColumnNew - New.treeViewColumnSetTitle col3 "Symbol" - New.treeViewColumnSetSizing col3 TreeViewColumnAutosize - New.treeViewColumnSetResizable col3 True - New.treeViewColumnSetReorderable col3 True - New.treeViewAppendColumn treeView col3 - New.cellLayoutPackStart col3 renderer30 False - New.cellLayoutPackStart col3 renderer3 True - New.cellLayoutSetAttributes col3 renderer3 listStore - $ \row -> [ New.cellText := descrName row] - New.cellLayoutSetAttributes col3 renderer30 listStore + renderer3 <- cellRendererTextNew + renderer30 <- cellRendererPixbufNew + col3 <- treeViewColumnNew + treeViewColumnSetTitle col3 "Symbol" + treeViewColumnSetSizing col3 TreeViewColumnAutosize + treeViewColumnSetResizable col3 True + treeViewColumnSetReorderable col3 True + treeViewAppendColumn treeView col3 + cellLayoutPackStart col3 renderer30 False + cellLayoutPackStart col3 renderer3 True + cellLayoutSetAttributes col3 renderer3 listStore + $ \row -> [ cellText := descrName row] + cellLayoutSetAttributes col3 renderer30 listStore $ \row -> [ - New.cellPixbufStockId := stockIdFromType ((descrType . details) row)] + cellPixbufStockId := stockIdFromType ((descrType . details) row)] - renderer1 <- New.cellRendererTextNew - renderer10 <- New.cellRendererPixbufNew - col1 <- New.treeViewColumnNew - New.treeViewColumnSetTitle col1 "Module" - New.treeViewColumnSetSizing col1 TreeViewColumnAutosize - New.treeViewColumnSetResizable col1 True - New.treeViewColumnSetReorderable col1 True - New.treeViewAppendColumn treeView col1 - New.cellLayoutPackStart col1 renderer10 False - New.cellLayoutPackStart col1 renderer1 True - New.cellLayoutSetAttributes col1 renderer1 listStore - $ \row -> [ New.cellText := display $ modu $ descrModu' row] - New.cellLayoutSetAttributes col1 renderer10 listStore + renderer1 <- cellRendererTextNew + renderer10 <- cellRendererPixbufNew + col1 <- treeViewColumnNew + treeViewColumnSetTitle col1 "Module" + treeViewColumnSetSizing col1 TreeViewColumnAutosize + treeViewColumnSetResizable col1 True + treeViewColumnSetReorderable col1 True + treeViewAppendColumn treeView col1 + cellLayoutPackStart col1 renderer10 False + cellLayoutPackStart col1 renderer1 True + cellLayoutSetAttributes col1 renderer1 listStore + $ \row -> [ cellText := display $ modu $ descrModu' row] + cellLayoutSetAttributes col1 renderer10 listStore $ \row -> [ - New.cellPixbufStockId := if isReexported row + cellPixbufStockId := if isReexported row then "ide_reexported" else if isJust (mbLocation row) then "ide_source" else ""] - renderer2 <- New.cellRendererTextNew - col2 <- New.treeViewColumnNew - New.treeViewColumnSetTitle col2 "Package" - New.treeViewColumnSetSizing col2 TreeViewColumnAutosize - New.treeViewColumnSetResizable col2 True - New.treeViewColumnSetReorderable col2 True - New.treeViewAppendColumn treeView col2 - New.cellLayoutPackStart col2 renderer2 True - New.cellLayoutSetAttributes col2 renderer2 listStore - $ \row -> [ New.cellText := display $ pack $ descrModu' row] + renderer2 <- cellRendererTextNew + col2 <- treeViewColumnNew + treeViewColumnSetTitle col2 "Package" + treeViewColumnSetSizing col2 TreeViewColumnAutosize + treeViewColumnSetResizable col2 True + treeViewColumnSetReorderable col2 True + treeViewAppendColumn treeView col2 + cellLayoutPackStart col2 renderer2 True + cellLayoutSetAttributes col2 renderer2 listStore + $ \row -> [ cellText := display $ pack $ descrModu' row] - New.treeViewSetHeadersVisible treeView True - sel <- New.treeViewGetSelection treeView - New.treeSelectionSetMode sel SelectionSingle + treeViewSetHeadersVisible treeView True + sel <- treeViewGetSelection treeView + treeSelectionSetMode sel SelectionSingle sw <- scrolledWindowNew Nothing Nothing containerAdd sw treeView @@ -232,7 +231,7 @@ active <- toggleButtonGetActive mb4 (reflectIDE (modeSelectionCase active) ideR ) treeView `onButtonPress` (listViewPopup ideR listStore treeView) - sel `New.onSelectionChanged` do + sel `onSelectionChanged` do fillInfo search ideR entry `afterKeyRelease` (\ event -> do text <- entryGetText entry @@ -283,12 +282,12 @@ then return [] else searchMeta scope str mode liftIO $ do - New.listStoreClear (searchStore search) - mapM_ (New.listStoreAppend (searchStore search)) (take 500 descrs) + listStoreClear (searchStore search) + mapM_ (listStoreAppend (searchStore search)) (take 500 descrs) listViewPopup :: IDERef - -> New.ListStore Descr - -> New.TreeView + -> ListStore Descr + -> TreeView -> Event -> IO (Bool) listViewPopup ideR store descrView (Button _ click _ _ _ _ button _ _) = do @@ -319,15 +318,15 @@ return False listViewPopup _ _ _ _ = throwIDE "listViewPopup wrong event type" -getSelectionDescr :: New.TreeView - -> New.ListStore Descr +getSelectionDescr :: TreeView + -> ListStore Descr -> IO (Maybe Descr) getSelectionDescr treeView listStore = do - treeSelection <- New.treeViewGetSelection treeView - paths <- New.treeSelectionGetSelectedRows treeSelection + treeSelection <- treeViewGetSelection treeView + paths <- treeSelectionGetSelectedRows treeSelection case paths of [a]:r -> do - val <- New.listStoreGetValue listStore a + val <- listStoreGetValue listStore a return (Just val) _ -> return Nothing @@ -346,8 +345,8 @@ setChoices descrs = do search <- getSearch liftIO $ do - New.listStoreClear (searchStore search) - mapM_ (New.listStoreAppend (searchStore search)) descrs + listStoreClear (searchStore search) + mapM_ (listStoreAppend (searchStore search)) descrs bringPaneToFront search entrySetText (entry search) "" diff --git a/src/IDE/Pane/SourceBuffer.hs b/src/IDE/Pane/SourceBuffer.hs --- a/src/IDE/Pane/SourceBuffer.hs +++ b/src/IDE/Pane/SourceBuffer.hs @@ -36,6 +36,7 @@ , fileCloseAllButPackage , fileSave , fileSaveAll +, fileSaveBuffer , editUndo , editRedo , editCut @@ -81,17 +82,15 @@ import System.Time import IDE.Core.State -import Control.Event import IDE.FileUtils import IDE.SourceCandy import IDE.Completion as Completion (complete,cancel) import Debug.Trace (trace) import qualified System.IO.UTF8 as UTF8 -import Graphics.UI.Gtk.Gdk.Enums (Modifier(..)) -import qualified Graphics.UI.Gtk.Gdk.Events as G (Event(..)) import Data.IORef (writeIORef,readIORef,newIORef,IORef(..)) import Graphics.UI.Frame.Panes (IDEPane(..)) import Data.Char (isAlphaNum) +import Control.Event (triggerEvent) -- -- | A text editor pane description @@ -153,10 +152,6 @@ fileClose return () -controlIsPressed :: G.Event -> Bool -controlIsPressed (G.Button _ _ _ _ _ mods _ _ _) | Control `elem` mods = True -controlIsPressed _ = False - instance RecoverablePane IDEBuffer BufferState IDEM where saveState p = do buf <- liftIO $ textViewGetBuffer (sourceView p) ins <- liftIO $ textBufferGetInsert buf @@ -408,13 +403,14 @@ liftIO $do widgetShowAll (scrolledWindow buf) widgetGrabFocus (sourceView buf) --- patch for windows - fdesc <- fontDescriptionFromString (case textviewFont prefs of Just str -> str; Nothing -> "") - fds <- fontDescriptionGetSize fdesc - when (isJust fds) $ do - fontDescriptionSetSize fdesc (fromJust fds + 0.01) - widgetModifyFont (castToWidget $ sourceView buf) (Just fdesc) +-- TODO: patch for windows, maybe we can remove it again +-- fdesc <- fontDescriptionFromString (case textviewFont prefs of Just str -> str; Nothing -> "") +-- fds <- fontDescriptionGetSize fdesc +-- when (isJust fds) $ do +-- fontDescriptionSetSize fdesc (fromJust fds + 0.01) +-- widgetModifyFont (castToWidget $ sourceView buf) (Just fdesc) -- end patch + when (isJust mbfn) $ removeRecentlyUsedFile (fromJust mbfn) return buf checkModTime :: IDEBuffer -> IDEM Bool @@ -706,6 +702,8 @@ then return False else do closePane currentBuffer + when (isJust $ fileName currentBuffer) + (addRecentlyUsedFile (fromJust $ fileName currentBuffer)) return True @@ -1004,7 +1002,25 @@ name <- sourceLanguageGetName lang return (Just name, Just lang) +addRecentlyUsedFile :: FilePath -> IDEAction +addRecentlyUsedFile fp = do + state <- readIDE currentState + when (not $ isStartingOrClosing state) $ do + recentFiles' <- readIDE recentFiles + unless (elem fp recentFiles') $ + modifyIDE_ (\ide -> return ide{recentFiles = take 12 (fp : recentFiles')}) + ask >>= \ideR -> triggerEvent ideR UpdateRecent + return () +removeRecentlyUsedFile :: FilePath -> IDEAction +removeRecentlyUsedFile fp = do + state <- readIDE currentState + when (not $ isStartingOrClosing state) $ do + recentFiles' <- readIDE recentFiles + when (elem fp recentFiles') $ + modifyIDE_ (\ide -> return ide{recentFiles = filter (\e -> e /= fp) recentFiles'}) + ask >>= \ideR -> triggerEvent ideR UpdateRecent + return () diff --git a/src/IDE/SaveSession.hs b/src/IDE/SaveSession.hs --- a/src/IDE/SaveSession.hs +++ b/src/IDE/SaveSession.hs @@ -33,19 +33,16 @@ import qualified Data.Map as Map import Data.Maybe import Data.Typeable ---import GHC.Exception (catch) ---import Debug.Trace import IDE.Core.State import IDE.FileUtils import IDE.PrinterParser import qualified Text.PrettyPrint.HughesPJ as PP import Graphics.UI.Editor.Parameters ---import IDE.Package import IDE.Pane.Modules import IDE.Pane.SourceBuffer import IDE.Pane.Info -import IDE.Pane.Callers +import IDE.Pane.References import IDE.Pane.Log import IDE.Pane.Preferences import IDE.Pane.PackageFlags @@ -63,7 +60,7 @@ | LogSt LogState | InfoSt InfoState | ModulesSt ModulesState - | CallersSt CallersState + | ReferencesSt ReferencesState | PrefsSt PrefsState | FlagsSt FlagsState | SearchSt SearchState @@ -74,7 +71,7 @@ asPaneState s | isJust ((cast s) :: Maybe LogState) = LogSt (fromJust $ cast s) asPaneState s | isJust ((cast s) :: Maybe InfoState) = InfoSt (fromJust $ cast s) asPaneState s | isJust ((cast s) :: Maybe ModulesState) = ModulesSt (fromJust $ cast s) -asPaneState s | isJust ((cast s) :: Maybe CallersState) = CallersSt (fromJust $ cast s) +asPaneState s | isJust ((cast s) :: Maybe ReferencesState) = ReferencesSt (fromJust $ cast s) asPaneState s | isJust ((cast s) :: Maybe PrefsState) = PrefsSt (fromJust $ cast s) asPaneState s | isJust ((cast s) :: Maybe FlagsState) = FlagsSt (fromJust $ cast s) asPaneState s | isJust ((cast s) :: Maybe SearchState) = SearchSt (fromJust $ cast s) @@ -85,7 +82,7 @@ recover pp (LogSt p) = recoverState pp p recover pp (InfoSt p) = recoverState pp p recover pp (ModulesSt p) = recoverState pp p -recover pp (CallersSt p) = recoverState pp p +recover pp (ReferencesSt p) = recoverState pp p recover pp (PrefsSt p) = recoverState pp p recover pp (FlagsSt p) = recoverState pp p recover pp (SearchSt p) = recoverState pp p @@ -115,6 +112,8 @@ , activePaneN :: Maybe String , toolbarVisibleS :: Bool , findbarState :: (Bool,FindState) + , recentOpenedFiles :: [FilePath] + , recentOpenedPackages :: [FilePath] } deriving() defaultLayout = SessionState { @@ -134,7 +133,10 @@ , entireWord = False , wrapAround = True , backward = False - , lineNr = 1})} + , lineNr = 1}) + , recentOpenedFiles = [] + , recentOpenedPackages = [] +} layoutDescr :: [FieldDescriptionS SessionState] layoutDescr = [ @@ -185,14 +187,26 @@ (PP.text . show) readParser findbarState - (\fp a -> a{findbarState = fp})] + (\fp a -> a{findbarState = fp}) + , mkFieldS + (paraName <<<- ParaName "Recently opened files" $ emptyParams) + (PP.text . show) + readParser + recentOpenedFiles + (\fp a -> a{recentOpenedFiles = fp}) + , mkFieldS + (paraName <<<- ParaName "Recently opened packages" $ emptyParams) + (PP.text . show) + readParser + recentOpenedPackages + (\fp a -> a{recentOpenedPackages = fp})] -- -- | Get and save the current layout -- saveSession :: IDEAction saveSession = do - sessionPath <- liftIO $getConfigFilePathForSave standardSessionFilename + sessionPath <- liftIO $ getConfigFilePathForSave standardSessionFilename saveSessionAs sessionPath saveSessionAs :: FilePath -> IDEAction @@ -201,19 +215,22 @@ if forget then ideMessage Normal "Forget this session" else do - ideMessage Normal "Now saving session" + sysMessage Normal "Now saving session" wdw <- readIDE window layout <- getLayout population <- getPopulation - size <- liftIO $windowGetSize wdw + size <- liftIO $ windowGetSize wdw active <- getActive activePane' <- readIDE activePane let activeP = case activePane' of Nothing -> Nothing Just (s,_) -> Just s - toolbarVisible <- readIDE toolbarVisible + (toolbarVisible,_) <- readIDE toolbar findState <- getFindState + (findbarVisible,_) <- readIDE findbar timeNow <- liftIO getClockTime + recentFiles' <- readIDE recentFiles + recentPackages' <- readIDE recentPackages liftIO $ writeLayout sessionPath (SessionState { saveTime = show timeNow , layoutS = layout @@ -222,7 +239,9 @@ , activePackage = active , activePaneN = activeP , toolbarVisibleS = toolbarVisible - , findbarState = (False,findState)}) + , findbarState = (findbarVisible,findState) + , recentOpenedFiles = recentFiles' + , recentOpenedPackages= recentPackages'}) saveSessionAsPrompt :: IDEAction saveSessionAsPrompt = do @@ -284,12 +303,15 @@ loadSession sessionPath = do saveSession :: IDEAction deactivatePackage + recentFiles' <- readIDE recentFiles + recentPackages' <- readIDE recentPackages b <- fileCloseAll if b then do paneCloseAll viewCollapseAll recoverSession sessionPath + modifyIDE_ (\ide -> return ide{recentFiles = recentFiles', recentPackages = recentPackages'}) return () else return () @@ -348,7 +370,7 @@ case mbSt of Nothing -> return (Nothing, fst v) Just st -> return (Just (asPaneState st), fst v)) - $Map.toList paneMap + $ Map.toList paneMap getActive :: IDEM(Maybe String) getActive = do @@ -368,27 +390,29 @@ recoverSession :: FilePath -> IDEM (Bool,Bool) recoverSession sessionPath = do wdw <- readIDE window - layoutSt <- liftIO$ readLayout sessionPath - liftIO $windowSetDefaultSize wdw (fst (windowSize layoutSt))(snd (windowSize layoutSt)) - applyLayout (layoutS layoutSt) - case activePackage layoutSt of + sessionSt <- liftIO $ readLayout sessionPath + liftIO $ windowSetDefaultSize wdw (fst (windowSize sessionSt))(snd (windowSize sessionSt)) + applyLayout (layoutS sessionSt) + case activePackage sessionSt of Just fp -> activatePackage fp >> return () Nothing -> return () - populate (population layoutSt) - setCurrentPages (layoutS layoutSt) - when (isJust (activePaneN layoutSt)) $ do - mbPane <- mbPaneFromName (fromJust (activePaneN layoutSt)) + populate (population sessionSt) + setCurrentPages (layoutS sessionSt) + when (isJust (activePaneN sessionSt)) $ do + mbPane <- mbPaneFromName (fromJust (activePaneN sessionSt)) case mbPane of Nothing -> return () Just (PaneC p) -> makeActive p - setFindState ((snd . findbarState) layoutSt) - if toolbarVisibleS layoutSt + setFindState ((snd . findbarState) sessionSt) + if toolbarVisibleS sessionSt then showToolbar else hideToolbar - if (fst . findbarState) layoutSt + if (fst . findbarState) sessionSt then showFindbar else hideFindbar - return (toolbarVisibleS layoutSt, (fst . findbarState) layoutSt) + modifyIDE_ (\ide -> return ide{recentFiles = recentOpenedFiles sessionSt, + recentPackages = recentOpenedPackages sessionSt}) + return (toolbarVisibleS sessionSt, (fst . findbarState) sessionSt) readLayout :: FilePath -> IO SessionState readLayout sessionPath = do @@ -444,10 +468,9 @@ setCurrentPages' b (BottomP : p) setCurrentPages' (VerticalP l r _) p = do setCurrentPages' l (LeftP : p) setCurrentPages' r (RightP : p) - setCurrentPages' (TerminalP _ ind) p = when (ind > 0) $ do + setCurrentPages' (TerminalP _ ind) p = when (ind >= 0) $ do nb <- getNotebook (reverse p) liftIO $ notebookSetCurrentPage nb ind - diff --git a/src/IDE/SpecialEditors.hs b/src/IDE/SpecialEditors.hs --- a/src/IDE/SpecialEditors.hs +++ b/src/IDE/SpecialEditors.hs @@ -24,7 +24,6 @@ import Graphics.UI.Editor.Simple (intEditor,genericEditor,staticListEditor,comboSelectionEditor,stringEditor,fileEditor) import Graphics.UI.Gtk -import Graphics.UI.Gtk.ModelView as New import Graphics.UI.Gtk.SourceView (sourceStyleSchemeManagerGetSchemeIds) import Graphics.UI.Gtk.SourceView (sourceStyleSchemeManagerNew) import Distribution.ModuleName (ModuleName(..)) @@ -66,8 +65,8 @@ testedWidthEditor :: Editor [(CompilerFlavor, VersionRange)] testedWidthEditor para = do multisetEditor - (ColumnDescr True [("Compiler Flavor",\(cv,_) -> [New.cellText := show cv]) - ,("Version Range",\(_,vr) -> [New.cellText := display vr])]) + (ColumnDescr True [("Compiler Flavor",\(cv,_) -> [cellText := show cv]) + ,("Version Range",\(_,vr) -> [cellText := display vr])]) (pairEditor (compilerFlavorEditor, paraShadow <<<- (ParaShadow ShadowNone) $ emptyParams) (versionRangeEditor, paraShadow <<<- (ParaShadow ShadowNone) $ emptyParams), @@ -211,8 +210,8 @@ dependenciesEditor :: [PackageIdentifier] -> Editor [Dependency] dependenciesEditor packages p noti = multisetEditor - (ColumnDescr True [("Package",\(Dependency (PackageName str) _) -> [New.cellText := str]) - ,("Version",\(Dependency _ vers) -> [New.cellText := display vers])]) + (ColumnDescr True [("Package",\(Dependency (PackageName str) _) -> [cellText := str]) + ,("Version",\(Dependency _ vers) -> [cellText := display vers])]) (dependencyEditor packages, paraOuterAlignment <<<- ParaInnerAlignment (0.0, 0.5, 1.0, 1.0) $ paraInnerAlignment <<<- ParaOuterAlignment (0.0, 0.5, 1.0, 1.0) @@ -228,7 +227,7 @@ filesEditor :: Maybe FilePath -> FileChooserAction -> String -> Editor [FilePath] filesEditor fp act label p = multisetEditor - (ColumnDescr False [("",(\row -> [New.cellText := row]))]) + (ColumnDescr False [("",(\row -> [cellText := row]))]) (fileEditor fp act label, emptyParams) (paraShadow <<<- ParaShadow ShadowIn $ paraDirection <<<- ParaDirection Vertical $ p) @@ -236,7 +235,7 @@ stringsEditor :: (String -> Bool) -> Editor [String] stringsEditor validation p = multisetEditor - (ColumnDescr False [("",(\row -> [New.cellText := row]))]) + (ColumnDescr False [("",(\row -> [cellText := row]))]) (stringEditor validation, emptyParams) (paraShadow <<<- ParaShadow ShadowIn $ p) @@ -347,10 +346,10 @@ executablesEditor :: Maybe FilePath -> [ModuleName] -> Int -> Editor [Executable'] executablesEditor fp modules countBuildInfo p = multisetEditor - (ColumnDescr True [("Executable Name",\(Executable' exeName _ _) -> [New.cellText := exeName]) - ,("Module Path",\(Executable' _ mp _) -> [New.cellText := mp]) + (ColumnDescr True [("Executable Name",\(Executable' exeName _ _) -> [cellText := exeName]) + ,("Module Path",\(Executable' _ mp _) -> [cellText := mp]) - ,("Build info index",\(Executable' _ _ bii) -> [New.cellText := show (bii + 1)])]) + ,("Build info index",\(Executable' _ _ bii) -> [cellText := show (bii + 1)])]) (executableEditor fp modules countBuildInfo,emptyParams) (paraShadow <<<- ParaShadow ShadowIn $ p)