leksah 0.4.1 → 0.4.2
raw patch · 32 files changed
+1906/−1480 lines, 32 files
Files
- data/Current.session +1/−1
- data/Default.menu +2/−0
- leksah.cabal +18/−19
- src/Graphics/UI/Editor/Composite.hs +35/−36
- src/Graphics/UI/Editor/MakeEditor.hs +14/−15
- src/Graphics/UI/Editor/Simple.hs +44/−45
- src/Graphics/UI/Frame/Panes.hs +1/−0
- src/IDE/Completion.hs +34/−35
- src/IDE/Core/State.hs +35/−5
- src/IDE/Core/Types.hs +3/−3
- src/IDE/Find.hs +105/−38
- src/IDE/ImportTool.hs +380/−0
- src/IDE/Leksah.hs +66/−32
- src/IDE/Menu.hs +42/−7
- src/IDE/Metainfo/GHCUtils.hs +125/−9
- src/IDE/Metainfo/InterfaceCollector.hs +1/−1
- src/IDE/Metainfo/Provider.hs +3/−1
- src/IDE/Metainfo/SourceCollector.hs +2/−40
- src/IDE/NotebookFlipper.hs +26/−27
- src/IDE/Package.hs +37/−8
- src/IDE/Pane/Callers.hs +0/−275
- src/IDE/Pane/ClassHierarchy.hs +131/−132
- src/IDE/Pane/Info.hs +21/−9
- src/IDE/Pane/Log.hs +8/−396
- src/IDE/Pane/Modules.hs +306/−231
- src/IDE/Pane/PackageEditor.hs +2/−3
- src/IDE/Pane/PackageFlags.hs +1/−1
- src/IDE/Pane/References.hs +315/−0
- src/IDE/Pane/Search.hs +58/−59
- src/IDE/Pane/SourceBuffer.hs +29/−13
- src/IDE/SaveSession.hs +52/−29
- src/IDE/SpecialEditors.hs +9/−10
data/Current.session view
@@ -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
@@ -3,6 +3,7 @@ <menu name="_File" action="File"> <menuitem name="_New" action="FileNew" /> <menuitem name="_Open" action="FileOpen" />+ <menuitem name="_Recent Files" action="RecentFiles"/> <menuitem name="_Save" action="FileSave" /> <menuitem name="Save _As" action="FileSaveAs" /> <menuitem name="Save _All" action="FileSaveAll" />@@ -45,6 +46,7 @@ <menu name="_Package" action="Package"> <menuitem name="_New Package" action="NewPackage" /> <menuitem name="_Open Package" action="OpenPackage" />+ <menuitem name="_Recent Packages" action="RecentPackages"/> <menuitem name="_Close Package" action="ClosePackage" /> <separator/> <menuitem name="_Edit Cabal" action="EditPackage" />
leksah.cabal view
@@ -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
src/Graphics/UI/Editor/Composite.hs view
@@ -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 ()
src/Graphics/UI/Editor/MakeEditor.hs view
@@ -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 ())
src/Graphics/UI/Editor/Simple.hs view
@@ -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
src/Graphics/UI/Frame/Panes.hs view
@@ -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
src/IDE/Completion.hs view
@@ -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
src/IDE/Core/State.hs view
@@ -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
src/IDE/Core/Types.hs view
@@ -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)
src/IDE/Find.hs view
@@ -8,7 +8,7 @@ -- -- Maintainer : Juergen Nicklisch-Franken <info at leksah.org> -- 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
+ src/IDE/ImportTool.hs view
@@ -0,0 +1,380 @@+-----------------------------------------------------------------------------+--+-- Module : IDE.ImportTool+-- Copyright : 2007-2009 Jürgen Nicklisch-Franken+-- License : GPL+--+-- Maintainer : Jutaro <jutaro@leksah.org>+-- 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+
src/IDE/Leksah.hs view
@@ -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
src/IDE/Menu.hs view
@@ -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
src/IDE/Metainfo/GHCUtils.hs view
@@ -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.+ }}
src/IDE/Metainfo/InterfaceCollector.hs view
@@ -291,7 +291,7 @@ moduleIdMD = PM pid mid , exportedNamesMD = exportedNames , mbSourcePathMD = Nothing- , usagesMD = uses+ , referencesMD = uses , idDescriptionsMD = ownDecls ++ inst ++ reexported} extractIdentifierDescr :: PackageIdentifier -> [ModuleName] -> IfaceDecl
src/IDE/Metainfo/Provider.hs view
@@ -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'
src/IDE/Metainfo/SourceCollector.hs view
@@ -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
src/IDE/NotebookFlipper.hs view
@@ -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
src/IDE/Package.hs view
@@ -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 ()
− src/IDE/Pane/Callers.hs
@@ -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 <info at leksah.org>--- Stability : experimental--- Portability : portable------ | The pane of ide where modules are presented in tree form with their--- packages and exports-------------------------------------------------------------------------------------module IDE.Pane.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--
src/IDE/Pane/ClassHierarchy.hs view
@@ -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)
src/IDE/Pane/Info.hs view
@@ -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
src/IDE/Pane/Log.hs view
@@ -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
src/IDE/Pane/Modules.hs view
@@ -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})
src/IDE/Pane/PackageEditor.hs view
@@ -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)),
src/IDE/Pane/PackageFlags.hs view
@@ -249,7 +249,7 @@ widgetShowAll vb return (flagsPane,[]) addPaneAdmin buf [] panePath- liftIO $widgetGrabFocus (flagsBox buf)+ liftIO $ widgetGrabFocus (flagsBox buf)
+ src/IDE/Pane/References.hs view
@@ -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 <info at leksah.org>+-- 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++
src/IDE/Pane/Search.hs view
@@ -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) ""
src/IDE/Pane/SourceBuffer.hs view
@@ -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 ()
src/IDE/SaveSession.hs view
@@ -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-
src/IDE/SpecialEditors.hs view
@@ -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)