leksah 0.4.4.1 → 0.6.0
raw patch · 74 files changed
+7396/−3129 lines, 74 filesdep +arraydep +regex-basedep +regex-compatdep ~Cabaldep ~basedep ~regex-posixnew-component:exe:leksahechobinary-added
Dependencies added: array, regex-base, regex-compat
Dependency ranges changed: Cabal, base, regex-posix
Files
- Readme +1/−2
- data/Current.session +8/−8
- data/Default.candy +7/−8
- data/Default.keymap +6/−0
- data/Default.menu +55/−4
- data/Default.prefs +32/−13
- data/ide_build.png binary
- data/ide_class.png binary
- data/ide_continue.png binary
- data/ide_data.png binary
- data/ide_debug.png binary
- data/ide_field.png binary
- data/ide_function.png binary
- data/ide_instance.png binary
- data/ide_konstructor.png binary
- data/ide_local.png binary
- data/ide_method.png binary
- data/ide_module.png binary
- data/ide_newtype.png binary
- data/ide_rebuild_meta.png binary
- data/ide_reexported.png binary
- data/ide_rule.png binary
- data/ide_run.png binary
- data/ide_slot.png binary
- data/ide_source.png binary
- data/ide_step.png binary
- data/ide_type.png binary
- data/leksah.png binary
- data/welcome.txt +2/−0
- leksah.cabal +44/−11
- src/DeepSeq.hs +14/−0
- src/Graphics/UI/Editor/Basics.hs +0/−2
- src/Graphics/UI/Editor/Composite.hs +2/−2
- src/Graphics/UI/Editor/MakeEditor.hs +14/−2
- src/Graphics/UI/Editor/Simple.hs +2/−3
- src/Graphics/UI/Frame/Panes.hs +47/−24
- src/Graphics/UI/Frame/ViewFrame.hs +1360/−653
- src/IDE/Completion.hs +227/−223
- src/IDE/Core/State.hs +163/−71
- src/IDE/Core/Types.hs +53/−13
- src/IDE/Debug.hs +443/−0
- src/IDE/FileUtils.hs +28/−25
- src/IDE/Find.hs +265/−146
- src/IDE/GUIHistory.hs +6/−10
- src/IDE/Group/Debugger.hs +72/−0
- src/IDE/ImportTool.hs +30/−21
- src/IDE/Leksah.hs +54/−203
- src/IDE/LogRef.hs +522/−0
- src/IDE/Menu.hs +396/−44
- src/IDE/Metainfo/GHCUtils.hs +2/−2
- src/IDE/Metainfo/InterfaceCollector.hs +1/−1
- src/IDE/Metainfo/Provider.hs +24/−46
- src/IDE/Metainfo/SourceCollector.hs +4/−3
- src/IDE/NotebookFlipper.hs +5/−4
- src/IDE/Package.hs +229/−340
- src/IDE/Pane/Breakpoints.hs +240/−0
- src/IDE/Pane/ClassHierarchy.hs +100/−107
- src/IDE/Pane/Errors.hs +246/−0
- src/IDE/Pane/Grep.hs +224/−0
- src/IDE/Pane/Info.hs +93/−99
- src/IDE/Pane/Log.hs +100/−86
- src/IDE/Pane/Modules.hs +145/−149
- src/IDE/Pane/PackageEditor.hs +152/−140
- src/IDE/Pane/PackageFlags.hs +43/−41
- src/IDE/Pane/Preferences.hs +160/−81
- src/IDE/Pane/References.hs +77/−78
- src/IDE/Pane/Search.hs +130/−136
- src/IDE/Pane/SourceBuffer.hs +360/−241
- src/IDE/Pane/Trace.hs +327/−0
- src/IDE/Pane/Variables.hs +332/−0
- src/IDE/SaveSession.hs +137/−82
- src/IDE/SourceCandy.hs +62/−5
- src/IDE/Tool.hs +326/−0
- src/LeksahEcho.hs +24/−0
Readme view
@@ -6,8 +6,7 @@ Leksah uses GTK+ as GUI Toolkit with the gtk2hs binding. It is plattform independend and should run on any plattform where GTK+, gtk2hs and ghc can be installed. It is currently been tested on Linux, Mac and Windows. It uses the Cabal package management-and build system for Package Management.-It currently only supports the Glasgow Haskell Compiler (ghc).+and build system for Package Management. It currently only supports the Glasgow Haskell Compiler (ghc). Documentation can be found on leksah.org.
data/Current.session view
@@ -1,15 +1,15 @@ Time of storage:- "Mon Mar 9 22:58:23 CET 2009"-Layout: VerticalP (TerminalP (Just TopP) (-1)) (HorizontalP (TerminalP (Just BottomP) 0) (TerminalP (Just BottomP) 0) 527) 762-Population: [(Just (LogSt LogState),[RightP,BottomP]),(Just (ModulesSt (ModulesState 347 (System,True) (Nothing,Nothing) (ExpanderState {localExp = ([],[]), localExpNoBlack = ([],[]), packageExp = ([],[]), packageExpNoBlack = ([],[]), systemExp = ([],[]), systemExpNoBlack = ([],[])}))),[RightP,TopP])]-Window size: (1393,903)+ "Mon May 25 15:28:15 CEST 2009"+Layout: VerticalP (TerminalP {paneGroups = fromList [], paneTabs = Just TopP, currentPage = 0, detachedId = Nothing, detachedSize = Nothing}) (HorizontalP (TerminalP {paneGroups = fromList [], paneTabs = Just BottomP, currentPage = 0, detachedId = Nothing, detachedSize = Nothing}) (TerminalP {paneGroups = fromList [], paneTabs = Just BottomP, currentPage = 0, detachedId = Nothing, detachedSize = Nothing}) 615) 889+Population: [(Just (InfoSt (InfoState (Descr {descrName' = "multisetEditor", typeInfo' = "multisetEditor :: forall alpha.\n (Show alpha, Default alpha, Eq alpha) =>\n ColumnDescr alpha\n -> (Editor alpha, Parameters)\n -> Maybe ([alpha] -> [alpha])\n -> Maybe (alpha -> alpha -> Bool)\n -> Editor [alpha]\n", descrModu' = PM {pack = PackageIdentifier {pkgName = PackageName "leksah", pkgVersion = Version {versionBranch = [0,5,0], versionTags = []}}, modu = ModuleName ["Graphics","UI","Editor","Composite"]}, mbLocation' = Just (Location {locationSLine = 499, locationSCol = 0, locationELine = 616, locationECol = 25}), mbComment' = Just "An editor with a subeditor, of which a list of items can be selected\n\n", details' = VariableDescr}))),[SplitP RightP,SplitP BottomP]),(Just (ModulesSt (ModulesState 313 (Package,True) (Nothing,Nothing) (ExpanderState {localExp = ([],[]), localExpNoBlack = ([[5,16],[5,13],[5,1],[5],[4,0,1],[4,0,0],[4,0],[4],[1,0],[1],[0]],[]), packageExp = ([],[]), packageExpNoBlack = ([],[]), systemExp = ([],[]), systemExpNoBlack = ([],[])}))),[SplitP RightP,SplitP TopP]),(Just (BufferSt (BufferState "/home/jutaro/Develop/leksah/data/welcome.txt" 800)),[SplitP LeftP])]+Window size: (1476,1171) Active package: Nothing-Active pane: Nothing+Active pane: Just "welcome.txt" Toolbar visible: True-FindbarState: (False,FindState {entryStr = "", entryHist = [], replaceStr = "", replaceHist = [], caseSensitive = False, entireWord = False, wrapAround = True, backward = False, lineNr = 1})+FindbarState: (False,FindState {entryStr = "paneP", entryHist = ["paneP","Group","stringxEditor","multiset"], replaceStr = "Category", replaceHist = [], caseSensitive = False, entireWord = False, wrapAround = True, regex = False, lineNr = 1}) Recently opened files:- []+ ["/home/jutaro/.leksah/Current.session","/home/jutaro/Develop/leksah/data/Current.session","/home/jutaro/Develop/leksah/doc/open_points.txt","/home/jutaro/Develop/leksah/src/Graphics/UI/Frame/ViewFrame.hs","/home/jutaro/Develop/leksah/src/IDE/Core/Types.hs","/home/jutaro/Develop/leksah/src/IDE/Pane/Preferences.hs","/home/jutaro/Develop/leksah/src/IDE/Pane/PackageEditor.hs","/home/jutaro/Develop/leksah/data/Default.prefs","/home/jutaro/.leksah/Default.prefs"] Recently opened packages:- []+ ["/home/jutaro/Develop/leksah/leksah.cabal"]
data/Default.candy view
@@ -9,20 +9,19 @@ "&&" 0x2227 --LOGICAL AND && - "||" 0x2228 --LOGICAL OR || - "++" 0x2295 --CIRCLED PLUS ++ ----"::" 0x2551 Trimming --BAR :: ----"::" 0x2237 Trimming --PROPORTION :: --".." 0x2025 --TWO DOT LEADER .. -+-- "::" 0x2237 Trimming --PROPORTION :: -+-- ".." 0x2025 --TWO DOT LEADER .. - "^" 0x2191 --UPWARDS ARROW ^ - "==" 0x2261 --IDENTICAL TO == - " . " 0x2218 --RING OPERATOR . - "\" 0x03bb --GREEK SMALL LETTER LAMBDA \ --"=<<" 0x291e -- =<< -+-- "=<<" 0x291e -- =<< - ">>=" 0x21a0 -- >>= --"$" 0x25ca -- $ --">>" 0x226b -- MUCH GREATER THEN >> -+-- "$" 0x25ca -- $ -+-- ">>" 0x226b -- MUCH GREATER THEN >> - -"forall" 0x2200 --FOR ALL-"exist" 0x2203 --THERE EXISTS+-- "forall" 0x2200 --FOR ALL+-- "exist" 0x2203 --THERE EXISTS "not" 0x00ac --NOT SIGN "alpha" 0x03b1 --ALPHA
data/Default.keymap view
@@ -100,4 +100,10 @@ <ctrl>space -> StartComplete "Initiate complete in a source buffer" +F6 -> DebugStep+F7 -> DebugStepLocal+F8 -> DebugStepModule+F9 -> DebugContinue++
@@ -39,9 +39,6 @@ <menuitem name="Align <-" action="EditAlignLeftArrow" /> <menuitem name="Align ->" action="EditAlignRightArrow" /> <menuitem name="Align ::" action="EditAlignTypeSig" />- <separator/>- <menuitem name="Source Candy" action="EditCandy" />- <menuitem name="Edit general Preferences" action="PrefsEdit" /> </menu> <menu name="_Package" action="Package"> <menuitem name="_New Package" action="NewPackage" />@@ -70,13 +67,30 @@ <separator/> <menuitem name="Open Documentation" action="OpenDocPackage" /> </menu>+ <menu name="_Debug" action="Debug">+ <menuitem name="Continue" action="DebugContinue" />+ <menuitem name="Abandon" action="DebugAbandon" />+ <menuitem name="Stop" action="DebugStop" />+ <separator/>+ <menuitem name="Step" action="DebugStep" />+ <menuitem name="Step Local" action="DebugStepLocal" />+ <menuitem name="Step Module" action="DebugStepModule" />+ <separator/>+ <menuitem name="Show Bin_dings" action="ShowBindings" />+ <menuitem name="Show _Context" action="ShowContext" />+ <menuitem name="Show Loaded _Modules" action="ShowLoadedModules" />+ <menuitem name="Show _Packages" action="ShowPackages" />+ <menuitem name="Show _Languages" action="ShowLanguages" />+ <separator/>+ <menuitem name="Show Debugger" action="ShowDebugger" />+ </menu> <menu name="_Metadata" action="Metadata"> <menuitem name="Update Project" action="UpdateMetadataCurrent" /> <menuitem name="Update Library" action="UpdateMetadataLib" /> <separator/> <menuitem name="Show _Info" action="ShowInfo" /> <menuitem name="Show _Modules" action="ShowModules" />- <menuitem name="Show _Classes" action="ShowClasses" />+ <menuitem name="Show _Search" action="ShowSearch" /> </menu> <menu name="_Session" action="Session"> <menuitem name="Save Session" action="SaveSession" />@@ -89,6 +103,9 @@ <menuitem name="_Collapse" action="ViewCollapse" /> <menuitem name="Close Pane" action="ViewClosePane" /> <separator/>+ <menuitem name="_Group" action="ViewNest" />+ <menuitem name="_Detach" action="ViewDetach" />+ <separator/> <menuitem name="Move _Left" action="ViewMoveLeft" /> <menuitem name="Move _Right" action="ViewMoveRight" /> <menuitem name="Move _Up" action="ViewMoveUp" />@@ -103,7 +120,13 @@ <menuitem name="Clear Log" action="ClearLog" /> <menuitem name="Toggle Toolbar" action="ToggleToolbar" /> </menu>+ <menu name="_Configuration" action="Configuration">+ <menuitem name="Source Candy" action="EditCandy" />+ <menuitem name="Edit general Preferences" action="PrefsEdit" />+ </menu> <menu name="_Help" action="Help">+ <menuitem name="_Homepage" action="HelpHomepage" />+ <menuitem name="_Manual (pdf)" action="HelpManual" /> <menuitem name="_About" action="HelpAbout" /> </menu> </menubar>@@ -137,9 +160,37 @@ <separator/> <toolitem name="BackgroundBuild" action="BackgroundBuildToggled"/> <toolitem name="BackgroundLink" action="BackgroundLinkToggled"/>+ <separator/>+ <toolitem name="Update Project" action="UpdateMetadataCurrent" />+ <separator/>+ <toolitem name="Debug" action="DebugToggled"/>+ <toolitem name="Step" action="DebugStep"/>+ <toolitem name="StepLocal" action="DebugStepLocal"/>+ <toolitem name="StepModule" action="DebugStepModule"/>+ <toolitem name="StepContinue" action="DebugContinue"/> </placeholder> </toolbar> <accelerator name="FlipUp" action="FlipUp"/> <accelerator name="FlipDown" action="FlipDown"/> <accelerator name="StartComplete" action="StartComplete"/>+ <accelerator name="_Start Debugger" action="StartDebugger" />+ <accelerator name="_Quit Debugger" action="QuitDebugger" />+ <accelerator name="_Execute Selection" action="ExecuteSelection" />+ <accelerator name="Set Breakpoint" action="DebugSetBreakpoint" />+ <accelerator name="Show Breakpoints" action="ShowBreakpoints" />+ <accelerator name="Show Next Breakpoint" action="ShowNextBreakpoint" />+ <accelerator name="Show Previous Breakpoint" action="ShowPreviousBreakpoint" />+ <accelerator name="Delete All Breakpoints" action="DebugDeleteAllBreakpoints" />+ <accelerator name="Step Expression" action="DebugStepExpression" />+ <accelerator name="Trace Expression" action="DebugTraceExpression" />+ <accelerator name="Trace" action="DebugTrace" />+ <accelerator name="History" action="DebugHistory" />+ <accelerator name="Back" action="DebugBack" />+ <accelerator name="Forward" action="DebugForward" />+ <accelerator name="Force" action="DebugForce" />+ <accelerator name="Print" action="DebugPrint" />+ <accelerator name="Simple Print" action="DebugSimplePrint" />+ <accelerator name="Information" action="DebugInformation" />+ <accelerator name="Kind" action="DebugKind" />+ <accelerator name="Type" action="DebugType" /> </ui>
data/Default.prefs view
@@ -11,9 +11,6 @@ True Source candy: "Default" --Empty for do not use or the name of a candy file in a config dir-Name of the keymap:- Default- --The name of a keymap file in a config dir Editor Style: "" LogView Font: "Sans 10" Window default size:@@ -21,20 +18,42 @@ --Default size of the main ide window specified as pair (int,int) Use ctrl Tab for Notebook flipper: True-Standard source pane path:- [LeftP]-Standard log pane path:- [RightP,BottomP]-Standard modules pane path:- [RightP,TopP]+Complete only on Hotkey:+ False+Name of the keymap:+ Default+ --The name of a keymap file in a config dir+Categories for panes:+ [("*ClassHierarchy","TreeCategory"),("*Debug","TreeCategory"),("*Grep","TreeCategory"),("*Info","LogCategory"),("*Log","LogCategory"),("*Modules","TreeCategory"),("*Package","DialogCategory"),("*Flags","DialogCategory"),("*Prefs","DialogCategory"),("*References","LogCategory"),("*Search","TreeCategory"),("*Errors","TreeCategory")]+Pane path for category:+ [("EditorCategory",[SplitP LeftP]),("TreeCategory",[SplitP RightP,SplitP TopP]),("LogCategory",[SplitP RightP,SplitP BottomP]),("DialogCategory",[SplitP LeftP])]+Default pane path:+ [SplitP LeftP] Paths under which haskell sources for packages may be found:- []+ ["xxx/.cabal/packages","xxx/Develop","xxx/Haskell"]+Extract packages from cabal-install:+ Just "xxx/.cabal/packages"+Update metadata at startup:+ True+Update metadata after every build:+ True Packages which are excluded from the modules pane: [Dependency (PackageName "ghc") AnyVersion]-Update metadata after every build:+Automatically save all files before building: True-Update metadata at startup:+Background build: True+Include linking in background builds:+ True+Enable usage of Show instances in :print:+ True+Break on any exception thrown:+ False+Break on uncaught exceptions and errors:+ False+Turn on printing of binding results in GHCi:+ False Browser: "firefox" URL for searching documentation:- "http://holumbus.fh-wedel.de/hayoo/hayoo.html?query="+ "http://holumbus.fh-wedel.de/hayoo/hayoo.html?query="+ --e.g Hoogle: http://www.haskell.org/hoogle/?q= or Hayoo: http://holumbus.fh-wedel.de/hayoo/hayoo.html?query=
data/ide_build.png view
binary file changed (5083 → 1958 bytes)
data/ide_class.png view
binary file changed (2294 → 521 bytes)
+ data/ide_continue.png view
binary file changed (absent → 601 bytes)
data/ide_data.png view
binary file changed (2112 → 172 bytes)
+ data/ide_debug.png view
binary file changed (absent → 3648 bytes)
− data/ide_field.png
binary file changed (1803 → absent bytes)
data/ide_function.png view
binary file changed (1816 → 778 bytes)
data/ide_instance.png view
binary file changed (1500 → 239 bytes)
data/ide_konstructor.png view
binary file changed (2219 → 203 bytes)
+ data/ide_local.png view
binary file changed (absent → 1340 bytes)
data/ide_method.png view
binary file changed (2333 → 811 bytes)
+ data/ide_module.png view
binary file changed (absent → 1307 bytes)
data/ide_newtype.png view
binary file changed (2165 → 161 bytes)
+ data/ide_rebuild_meta.png view
binary file changed (absent → 5083 bytes)
data/ide_reexported.png view
binary file changed (353 → 393 bytes)
data/ide_rule.png view
binary file changed (2248 → 356 bytes)
data/ide_run.png view
binary file changed (1553 → 3972 bytes)
data/ide_slot.png view
binary file changed (2488 → 173 bytes)
data/ide_source.png view
binary file changed (154 → 469 bytes)
+ data/ide_step.png view
binary file changed (absent → 1285 bytes)
data/ide_type.png view
binary file changed (1683 → 365 bytes)
data/leksah.png view
binary file changed (9415 → 12052 bytes)
data/welcome.txt view
@@ -1,4 +1,6 @@ ++ # # ###### # #### #### # # ###### ##### #### # # # # # # # # ## ## # # # # # # ##### # # # # # ## # ##### # # #
leksah.cabal view
@@ -1,5 +1,5 @@ name: leksah-version: 0.4.4.1+version: 0.6.0 cabal-version: >=1.4 build-type: Simple license: GPL@@ -19,27 +19,34 @@ data/Default.keymap data/Default.menu data/Default.prefs data/Emacs.keymap data/LICENSE data/Module.template data/ide_class.png data/ide_configure.png data/ide_data.png- data/ide_error_next.png data/ide_error_prev.png data/ide_field.png+ data/ide_error_next.png data/ide_error_prev.png data/ide_function.png data/ide_instance.png data/ide_konstructor.png data/ide_make.png data/ide_method.png data/ide_newtype.png data/ide_other.png data/ide_reexported.png data/ide_rule.png data/ide_run.png data/ide_slot.png data/ide_source.png data/ide_type.png data/leksah.png+ data/ide_step.png data/ide_local.png data/ide_module.png data/ide_continue.png+ data/ide_debug.png data/welcome.txt data/ide_clean.png data/ide_build.png data/ide_link.png+ data/ide_rebuild_meta.png data-dir: "" extra-source-files: Setup.lhs extra-tmp-files: Executable leksah if os(windows) build-depends: Win32 >=2.2.0.0+ extra-libraries: kernel32 else build-depends: unix >=2.3.1.0- build-depends: Cabal ==1.6.0.1, base >=4.0.0.0, binary >=0.4.4,+ if os(osx)+ extra-libraries: igemacintegration+ build-depends: Cabal >=1.6.0.1, base >=4.0.0.0 && <= 5.0, binary >=0.4.4, bytestring >=0.9.0.1, containers >=0.2.0.0, directory >=1.0.0.2, filepath >=1.1.0.1, ghc >=6.10.1, glib >=0.10, gtk >=0.10, gtksourceview2 >=0.10.0, mtl >=1.1.0.2, old-time >=1.0.0.1, parsec >=2.1.0.1, pretty >=1.0.1.0, process >=1.0.1.0,- regex-posix ==0.72.0.3, utf8-string >=0.3.1.1+ regex-posix >=0.72.0.3, regex-compat >=0.71.0.1,+ regex-base ==0.72.0.2, utf8-string >=0.3.1.1, array >=0.2.0.0 main-is: Main.hs buildable: True build-tools:@@ -50,11 +57,11 @@ frameworks: c-sources: extensions: CPP- extra-libraries:- extra-lib-dirs:- includes:+ if os(windows)+-- extra-lib-dirs: C:/cygwin/lib/w32api+ includes: windows.h+-- include-dirs: C:/cygwin/usr/include/w32api install-includes:- include-dirs: hs-source-dirs: src other-modules: Default DeepSeq MyMissing Data.Binary.Shared Control.Event Graphics.UI.Frame.ViewFrame Graphics.UI.Frame.Panes@@ -70,12 +77,38 @@ IDE.Pane.Preferences IDE.Pane.ClassHierarchy IDE.Pane.PackageEditor IDE.Pane.Info IDE.Pane.Log IDE.Pane.SourceBuffer IDE.Pane.Modules IDE.Pane.Search IDE.Pane.References IDE.Pane.PackageFlags+ IDE.Tool IDE.LogRef IDE.Debug IDE.Pane.Grep+ IDE.Pane.Breakpoints IDE.Pane.Trace IDE.Pane.Variables+ IDE.Pane.Errors IDE.Group.Debugger ghc-prof-options: -auto-all -prof ghc-shared-options: -auto-all -prof- ghc-options: -fwarn-unused-imports -fwarn-missing-fields -fwarn-incomplete-patterns+ ghc-options: -fwarn-unused-imports -fwarn-missing-fields -fwarn-incomplete-patterns -ferror-spans hugs-options: nhc98-options: jhc-options: --+Executable leksahecho+ build-depends:+ main-is: LeksahEcho.hs+ buildable: True+ build-tools:+ cpp-options:+ cc-options:+ ld-options:+ pkgconfig-depends:+ frameworks:+ c-sources:+ extensions: CPP+ extra-libraries:+ extra-lib-dirs:+ includes:+ install-includes:+ include-dirs:+ hs-source-dirs: src+ other-modules:+ ghc-prof-options: -auto-all -prof+ ghc-shared-options: -auto-all -prof+ ghc-options: -fwarn-unused-imports -fwarn-missing-fields -fwarn-incomplete-patterns -ferror-spans+ hugs-options:+ nhc98-options:+ jhc-options:
src/DeepSeq.hs view
@@ -1,3 +1,17 @@+-----------------------------------------------------------------------------+--+-- Module : Default+-- Copyright : (c) Juergen Nicklisch-Franken, Hamish Mackenzie+-- License : GNU-GPL+--+-- Maintainer : Juergen Nicklisch-Franken <info@leksah.org>+-- Stability : provisional+-- Portability : portable+--+-- | Module for default values of a data type+--+------------------------------------------------------------------------------+ module DeepSeq where class DeepSeq a where
src/Graphics/UI/Editor/Basics.hs view
@@ -41,8 +41,6 @@ import Data.IORef import Control.Monad ---import Debug.Trace- import Graphics.UI.Editor.Parameters import Control.Event import MyMissing(allOf)
src/Graphics/UI/Editor/Composite.hs view
@@ -669,8 +669,8 @@ $ emptyParams) (Just (sortBy (\ (Dependency p1 _) (Dependency p2 _) -> compare p1 p2))) (Just (\ (Dependency p1 _) (Dependency p2 _) -> p1 == p2))- (paraShadow <<<- ParaShadow ShadowIn $- paraOuterAlignment <<<- ParaInnerAlignment (0.0, 0.5, 1.0, 1.0)+ (paraShadow <<<- ParaShadow ShadowIn+ $ paraOuterAlignment <<<- ParaInnerAlignment (0.0, 0.5, 1.0, 1.0) $ paraInnerAlignment <<<- ParaOuterAlignment (0.0, 0.5, 1.0, 1.0) $ paraDirection <<<- ParaDirection Vertical $ paraPack <<<- ParaPack PackGrow
src/Graphics/UI/Editor/MakeEditor.hs view
@@ -1,5 +1,5 @@ --------------------------------------------------------------------------------+--group_Test -- Module : Graphics.UI.Editor.MakeEditor -- Copyright : (c) Juergen Nicklisch-Franken, Hamish Mackenzie -- License : GNU-GPL@@ -35,7 +35,7 @@ import Control.Event import Graphics.UI.Editor.Parameters import Graphics.UI.Editor.Basics-import Graphics.UI.Frame.ViewFrame+--import Graphics.UI.Frame.ViewFrame import Data.Maybe (isNothing) --@@ -62,6 +62,18 @@ parameters (VFD p _) = p parameters (HFD p _) = p parameters (NFD _) = emptyParams++--+-- | Construct a new notebook+--+newNotebook :: IO Notebook+newNotebook = do+ nb <- notebookNew+ notebookSetTabPos nb PosTop+ notebookSetShowTabs nb True+ notebookSetScrollable nb True+ notebookSetPopup nb True+ return nb buildEditor :: FieldDescription alpha -> alpha -> IO (Widget, Injector alpha , alpha -> Extractor alpha , Notifier) buildEditor (FD paras editorf) v = editorf v
src/Graphics/UI/Editor/Simple.hs view
@@ -34,8 +34,6 @@ import Graphics.UI.Gtk import qualified Graphics.UI.Gtk as Gtk-import IDE.Core.State (MessageLevel(..))-import IDE.Core.State (sysMessage) import Control.Monad import Data.IORef import Data.List@@ -167,6 +165,7 @@ Just (_,stockId3) -> return (Just stockId3)) parameters notifier+ -- -- | Editor for a string in the form of a text entry --@@ -275,7 +274,7 @@ Nothing -> return Nothing Just s -> catch (liftM Just (readIO s)) (\e -> do- sysMessage Normal $"Generic editor no parse for " ++ s ++ " " ++ show e+ putStrLn ("Generic editor no parse for " ++ s ++ " " ++ show e) return Nothing) return (wid,ginj,gext)
src/Graphics/UI/Frame/Panes.hs view
@@ -1,7 +1,8 @@ {-# OPTIONS_GHC -XExistentialQuantification -XMultiParamTypeClasses- -XFunctionalDependencies #-}+ -XFunctionalDependencies+ -XNoMonomorphismRestriction #-} ----------------------------------------------------------------------------- -- -- Module : IDE.Core.Panes@@ -9,7 +10,7 @@ -- License : GNU-GPL -- -- Maintainer : <maintainer at leksah.org>--- Stability : provisional+-- Stability : provisional21 -- Portability : portable -- -- | The basic definitions for all panes@@ -24,12 +25,14 @@ , IDEPane(..) , RecoverablePane(..) , PaneDirection(..)+, PanePathElement(..) , PanePath , PaneLayout(..) , PaneName , Connection(..) , Connections , StandardPath+, FrameState(..) , signalDisconnectAll ) where @@ -49,9 +52,15 @@ -- -- | A path to a pane ---type PanePath = [PaneDirection]+type PanePath = [PanePathElement] --+-- | An element of a path to a pane+--+data PanePathElement = SplitP PaneDirection | GroupP String+ deriving (Eq,Show,Read)++-- -- | The relative direction to a pane from the parent -- data PaneDirection = TopP | BottomP | LeftP | RightP@@ -63,7 +72,12 @@ -- data PaneLayout = HorizontalP PaneLayout PaneLayout Int | VerticalP PaneLayout PaneLayout Int- | TerminalP (Maybe PaneDirection) Int+ | TerminalP {+ paneGroups :: Map String PaneLayout+ , paneTabs :: Maybe PaneDirection+ , currentPage :: Int+ , detachedId :: Maybe String+ , detachedSize :: Maybe (Int, Int) } deriving (Eq,Show,Read) --@@ -81,8 +95,7 @@ getTopWidget :: alpha -> Widget paneId :: alpha -> String makeActive :: alpha -> beta ()--- makeActive _ = return ()- close :: alpha -> beta ()+ close :: alpha -> beta Bool class (Pane alpha delta, Read beta, Show beta, Typeable beta, PaneMonad delta) => RecoverablePane alpha beta delta | beta -> alpha, alpha -> beta where@@ -94,7 +107,7 @@ data IDEPane delta = forall alpha beta. (RecoverablePane alpha beta delta) => PaneC alpha instance Eq (IDEPane delta) where- (== ) (PaneC x) (PaneC y) = paneName x == paneName y+ (==) (PaneC x) (PaneC y) = paneName x == paneName y instance Ord (IDEPane delta) where (<=) (PaneC x) (PaneC y) = paneName x <= paneName y@@ -104,25 +117,20 @@ type StandardPath = PanePath +data FrameState delta = FrameState {+ windows :: [Window]+, uiManager :: UIManager+, panes :: Map PaneName (IDEPane delta)+, paneMap :: (Map PaneName (PanePath, Connections))+, activePane :: Maybe (PaneName, Connections)+, panePathFromNB :: Map Notebook PanePath+, layout :: PaneLayout} class MonadIO delta => PaneMonad delta where- getWindowSt :: delta Window- getUIManagerSt :: delta UIManager-- getPanesSt :: delta (Map PaneName (IDEPane delta))- setPanesSt :: Map PaneName (IDEPane delta) -> delta ()-- getPaneMapSt :: delta (Map PaneName (PanePath, Connections))- setPaneMapSt :: Map PaneName (PanePath, Connections) -> delta ()-- getActivePaneSt :: delta (Maybe (PaneName, Connections))- setActivePaneSt :: Maybe (PaneName, Connections) -> delta ()-- getLayoutSt :: delta PaneLayout- setLayoutSt :: PaneLayout -> delta ()-- runInIO :: forall beta. (beta -> delta()) -> delta (beta -> IO ())-+ setFrameState :: FrameState delta -> delta ()+ getFrameState :: delta (FrameState delta)+ runInIO :: forall alpha beta. (beta -> delta alpha) -> delta (beta -> IO alpha)+ panePathForGroup:: String -> delta PanePath -- -- | Signal handlers for the different pane types@@ -135,4 +143,19 @@ signalDisconnectAll = mapM_ (\ (ConnectC s) -> signalDisconnect s) +-- Necessary with pre 10.1 verion of gtk2hs +#ifdef MIN_VERSION_gtk+#if MIN_VERSION_gtk(0,10,1)+#else+instance Eq Notebook+ where (==) a b = let (GObject pa, GObject pb) = (toGObject a, toGObject b)+ in pa == pb+instance Ord Notebook+ where (<=) a b = let (GObject pa, GObject pb) = (toGObject a, toGObject b)+ in pa <= pb+instance Eq Window+ where (==) a b = let (GObject pa, GObject pb) = (toGObject a, toGObject b)+ in pa == pb+#endif+#endif
src/Graphics/UI/Frame/ViewFrame.hs view
@@ -1,653 +1,1360 @@-{-# OPTIONS_GHC #-}------------------------------------------------------------------------------------ Module : IDE.Core.ViewFrame--- Copyright : (c) Juergen Nicklisch-Franken, Hamish Mackenzie--- License : GNU-GPL------ Maintainer : <maintainer at leksah.org>--- Stability : provisional--- Portability : portable--------- | Splittable panes containing notebooks with any widgets---------------------------------------------------------------------------------------module Graphics.UI.Frame.ViewFrame (- removePaneAdmin-, addPaneAdmin-, notebookInsertOrdered---- * Convenience methods for accesing Pane state-, posTypeToPaneDirection-, paneDirectionToPosType-, paneFromName-, mbPaneFromName-, guiPropertiesFromName---- * View Actions-, viewMove-, viewSplitHorizontal-, viewSplitVertical-, viewSplit-, viewSplit'-, handleNotebookSwitch-, viewCollapse-, viewCollapse'-, viewTabsPos-, viewSwitchTabs---- * View Queries-, getStandardPanePath-, getActivePanePath-, getActivePanePathOrStandard-, figureOutPaneName-, getNotebook-, getPaned-, getActiveNotebook-, getPane-, getPanes---- * View Actions-, bringPaneToFront-, newNotebook---- * Accessing GUI elements---, widgetFromPath-, getUIAction-, widgetGet---) where--import Graphics.UI.Gtk hiding (afterToggleOverwrite,onToggleOverwrite)-import Control.Monad.Reader-import qualified Data.Map as Map-import Data.Map (Map)-import Data.List-import Data.Maybe-import Control.OldException(evaluate,catch)-import Prelude hiding(catch)-import Data.Unique-import Data.Typeable--import Graphics.UI.Frame.Panes-import Graphics.UI.Editor.Parameters--removePaneAdmin :: Pane alpha beta => alpha -> beta ()-removePaneAdmin pane = do- panes' <- getPanesSt- paneMap' <- getPaneMapSt- setPanesSt (Map.delete (paneName pane) panes')- setPaneMapSt (Map.delete (paneName pane) paneMap')--addPaneAdmin :: RecoverablePane alpha beta delta => alpha -> Connections -> PanePath -> delta ()-addPaneAdmin pane conn pp = do- panes' <- getPanesSt- paneMap' <- getPaneMapSt- unique <- liftIO newUnique- liftIO $ widgetSetName (getTopWidget pane) (show (hashUnique unique))- setPaneMapSt (Map.insert (paneName pane) (pp, conn) paneMap')- setPanesSt (Map.insert (paneName pane) (PaneC pane) panes')--getPane :: RecoverablePane alpha beta delta => delta (Maybe alpha)-getPane = do- selectedPanes <- getPanes- if null selectedPanes || length selectedPanes > 1- then return Nothing- else (return (Just $ head selectedPanes))--getPanes :: RecoverablePane alpha beta delta => delta ([alpha])-getPanes = do- panes' <- getPanesSt- return (catMaybes- $ map (\(PaneC p) -> cast p)- $ Map.elems panes')--notebookInsertOrdered :: (NotebookClass self, WidgetClass child) - => self - -> child -- child - the Widget to use as the contents of the page.- -> String -- tabLabel - the label for the page- -> Maybe Label- -> IO ()-notebookInsertOrdered nb widget label mbTabLabel = do- menuLabel <- labelNew (Just label)- tabLabel <- case mbTabLabel of- Nothing -> labelNew (Just label)- Just l -> return l- numPages <- notebookGetNPages nb- mbWidgets <- mapM (notebookGetNthPage nb) [0 .. (numPages-1)]- widgets <- catch (evaluate (map fromJust mbWidgets))- (\e -> error "ViewFrame.notebookInsertOrdered: no widget")- mbLabels <- mapM (notebookGetTabLabelText nb) widgets- labels <- catch (evaluate (map fromJust mbLabels))- (\e -> error "ViewFrame.notebookInsertOrdered: no label")- let pos = case findIndex (\s -> s > label) labels of- Just i -> i- Nothing -> -1- realPos <- notebookInsertPageMenu nb widget tabLabel menuLabel pos- notebookSetCurrentPage nb realPos---- | Constructs a unique pane name, which is an index and a string-figureOutPaneName :: Map String (IDEPane alpha) -> String -> Int -> (Int,String)-figureOutPaneName bufs bn ind =- let ind = foldr (\(PaneC buf) ind ->- if primPaneName buf == bn- then max ind ((getAddedIndex buf) + 1)- else ind)- 0 (Map.elems bufs)- in if ind == 0- then (0,bn)- else (ind,bn ++ "(" ++ show ind ++ ")")--paneFromName :: PaneMonad alpha => PaneName -> alpha (IDEPane alpha)-paneFromName pn = do- mbPane <- mbPaneFromName pn- case mbPane of- Just p -> return p- Nothing -> error $ "ViewFrame>>paneFromName:Can't find pane from unique name " ++ pn--mbPaneFromName :: PaneMonad alpha => PaneName -> alpha (Maybe (IDEPane alpha))-mbPaneFromName pn = do- panes <- getPanesSt- return (Map.lookup pn panes)---- |-guiPropertiesFromName :: PaneMonad alpha => PaneName -> alpha (PanePath, Connections)-guiPropertiesFromName pn = do- paneMap <- getPaneMapSt- case Map.lookup pn paneMap of- Just it -> return it- otherwise -> error $"Cant't find guiProperties from unique name " ++ pn--posTypeToPaneDirection PosLeft = LeftP-posTypeToPaneDirection PosRight = RightP -posTypeToPaneDirection PosTop = TopP-posTypeToPaneDirection PosBottom = BottomP --paneDirectionToPosType LeftP = PosLeft-paneDirectionToPosType RightP = PosRight -paneDirectionToPosType TopP = PosTop-paneDirectionToPosType BottomP = PosBottom------- | Toggle the tabs of the current notebook----viewSwitchTabs :: PaneMonad alpha => alpha ()-viewSwitchTabs = do- mbNb <- getActiveNotebook- case mbNb of- Nothing -> return ()- Just nb -> liftIO $ do- b <- notebookGetShowTabs nb- notebookSetShowTabs nb (not b)------- | Sets the tab position in the current notebook----viewTabsPos :: PaneMonad alpha => PositionType -> alpha ()-viewTabsPos pos = do- mbNb <- getActiveNotebook- case mbNb of- Nothing -> return ()- Just nb -> liftIO $notebookSetTabPos nb pos------- | Split the currently active pane in horizontal direction----viewSplitHorizontal :: PaneMonad alpha => alpha ()-viewSplitHorizontal = viewSplit Horizontal------- | Split the currently active pane in vertical direction----viewSplitVertical :: PaneMonad alpha => alpha ()-viewSplitVertical = viewSplit Vertical------- | The active view can be split in two (horizontal or vertical)----viewSplit :: PaneMonad alpha => Direction -> alpha ()-viewSplit dir = do- mbPanePath <- getActivePanePath- case mbPanePath of- Nothing -> return ()- Just panePath -> do- viewSplit' panePath dir---viewSplit' :: PaneMonad alpha => PanePath -> Direction -> alpha ()-viewSplit' panePath dir = do- activeNotebook <- getNotebook panePath-- mbPD <- do- mbParent <- liftIO $ widgetGetParent activeNotebook- case mbParent of- Nothing -> return Nothing- Just parent -> do- (nb,paneDir) <- liftIO $ do- --trace ("Pane path " ++ show panePath) return ()- newpane <- case dir of- Horizontal -> do h <- vPanedNew- return (castToPaned h)- Vertical -> do v <- hPanedNew- return (castToPaned v)- let (name,altname,paneDir) = case dir of- Horizontal -> ("top","bottom",TopP)- Vertical -> ("left","right",LeftP)- rName <- widgetGetName activeNotebook- widgetSetName newpane rName- nb <- newNotebook- widgetSetName nb altname- panedPack2 newpane nb True True- containerRemove (castToContainer parent) activeNotebook- widgetSetName activeNotebook name- panedPack1 newpane activeNotebook True True- if not (null panePath)- then- if (last panePath == TopP || last panePath == LeftP)- then panedPack1 (castToPaned parent) newpane True True- else panedPack2 (castToPaned parent) newpane True True- else do- boxPackStart (castToBox parent) newpane PackGrow 0- boxReorderChild (castToVBox parent) newpane 2- widgetShowAll newpane- widgetGrabFocus activeNotebook- return (nb,paneDir)- handleFunc <- runInIO (handleNotebookSwitch nb)- liftIO $ afterSwitchPage nb handleFunc- return (Just (paneDir,dir))- case mbPD of- Just (paneDir,pdir) -> do- let toPane = panePath ++ [paneDir]- adjustPane panePath toPane- adjustLayoutForSplit pdir panePath- viewMove (otherDirection paneDir)- Nothing -> return ()--handleNotebookSwitch :: PaneMonad beta => Notebook -> Int -> beta ()-handleNotebookSwitch nb index = do- mbW <- liftIO $ notebookGetNthPage nb index- case mbW of- Nothing -> error "ViewFrame/handleNotebookSwitch: Can't find widget"- Just w -> do- mbPane <- findPaneFor w- case mbPane of- Nothing -> return ()- Just (PaneC p) -> makeActive p- where- findPaneFor :: PaneMonad beta => Widget -> beta (Maybe (IDEPane beta))- findPaneFor w = do- panes' <- getPanesSt- n1 <- liftIO $ widgetGetName w- foldM (\r (PaneC p) -> do- n2 <- liftIO $ widgetGetName (getTopWidget p)- return (if n1 == n2 then (Just (PaneC p)) else r))- Nothing (Map.elems panes')------- | Two notebooks can be collapsed to one----viewCollapse :: PaneMonad alpha => alpha ()-viewCollapse = do- mbPanePath <- getActivePanePath- case mbPanePath of- Nothing -> return ()- Just panePath -> do- viewCollapse' panePath--viewCollapse' :: PaneMonad alpha => PanePath -> alpha ()-viewCollapse' panePath = do- layout1 <- getLayoutSt- let newPanePath = reverse $tail $reverse panePath- let mbOtherSidePath = otherSide panePath- case mbOtherSidePath of- Nothing -> return ()- Just otherSidePath ->- let sp1 = getSubpath panePath layout1- sp2 = getSubpath otherSidePath layout1- in do- case sp1 of- Nothing -> return ()- Just sp -> viewCollapse' sp- case sp2 of- Nothing -> return ()- Just sp -> viewCollapse' sp- paneMap <- getPaneMapSt- activeNotebook <- getNotebook panePath- let paneNamesToMove = map (\(w,(p,_)) -> w)- $filter (\(w,(p,_)) -> p == otherSidePath)- $Map.toList paneMap- panesToMove <- mapM paneFromName paneNamesToMove- mapM_ (\(PaneC p) -> move panePath p) panesToMove- liftIO $ do- mbParent <- widgetGetParent activeNotebook- case mbParent of- Nothing -> error "collapse: no parent"- Just parent -> do- mbGrandparent <- widgetGetParent parent- case mbGrandparent of- Nothing -> error "collapse: no grandparent"- Just grandparent -> do- containerRemove (castToContainer grandparent) parent- containerRemove (castToContainer parent) activeNotebook- if length panePath > 1- then do- let dir = last newPanePath- if (dir == TopP || dir == LeftP)- then panedPack1 (castToPaned grandparent)- activeNotebook True True- else panedPack2 (castToPaned grandparent)- activeNotebook True True- widgetSetName activeNotebook $paneDirectionToWidgetName dir- else do- boxPackStart (castToVBox grandparent) activeNotebook PackGrow 0- boxReorderChild (castToVBox grandparent) activeNotebook 2- widgetSetName activeNotebook "root"- adjustLayoutForCollapse newPanePath- adjustPane panePath newPanePath- --adjustPane otherSidePath newPanePath------- | Moves the given Pane to the given path----move :: Pane alpha beta => PanePath -> alpha -> beta ()-move toPane idew = do- paneMap <- getPaneMapSt- let child = getTopWidget idew- (fromPane,cid) <- guiPropertiesFromName (paneName idew)- fromNB <- getNotebook fromPane- toNB <- getNotebook toPane- liftIO $ do- mbNum <- notebookPageNum fromNB child- case mbNum of- Nothing -> return ()- Just pn -> do- mbText <- notebookGetTabLabelText fromNB child- mbLabel <- notebookGetTabLabel fromNB child- case (mbText,mbLabel) of- (Just text, Just label) -> do- notebookRemovePage fromNB pn- notebookInsertOrdered toNB child text (Just (castToLabel label))- _ -> return ()- let paneMap1 = Map.delete (paneName idew) paneMap- setPaneMapSt $ Map.insert (paneName idew) (toPane,cid) paneMap1------- | Moves the activePane in the given direction, if possible--- | If their are many possibilities choose the leftmost and topmost----viewMove :: PaneMonad beta => PaneDirection -> beta ()-viewMove direction = do- mbPane <- getActivePaneSt- case mbPane of- Nothing -> do- return ()- Just (paneName,_) -> do- (PaneC pane) <- paneFromName paneName- mbPanePath <- getActivePanePath- case mbPanePath of- Nothing -> do- return ()- Just panePath -> do- layout <- getLayoutSt- case findMoveTarget panePath layout direction of- Nothing -> do- return ()- Just moveTo -> move moveTo pane------- | Find the target for a move----findMoveTarget :: PanePath -> PaneLayout -> PaneDirection -> Maybe PanePath-findMoveTarget panePath layout direction=- let reversedPath = reverse panePath- oppositeDir = otherDirection direction- cutPath = dropWhile (\d -> d /= oppositeDir) reversedPath- in if null cutPath- then Nothing- else let basePath = reverse (direction : tail cutPath)- layoutP = layoutFromPath basePath layout- in Just $basePath ++ findAppropriate layoutP oppositeDir--findAppropriate :: PaneLayout -> PaneDirection -> PanePath-findAppropriate (TerminalP _ _) _ = []-findAppropriate (HorizontalP t b _) LeftP = TopP : findAppropriate t LeftP-findAppropriate (HorizontalP t b _) RightP = TopP : findAppropriate t RightP-findAppropriate (HorizontalP t b _) BottomP = BottomP : findAppropriate b BottomP-findAppropriate (HorizontalP t b _) TopP = TopP : findAppropriate b TopP-findAppropriate (VerticalP l r _) LeftP = LeftP : findAppropriate l LeftP-findAppropriate (VerticalP l r _) RightP = RightP : findAppropriate r RightP-findAppropriate (VerticalP l r _) BottomP = LeftP : findAppropriate l BottomP-findAppropriate (VerticalP l r _) TopP = LeftP : findAppropriate l TopP------- | Bring the pane to the front position in its notebook----bringPaneToFront :: Pane alpha beta => alpha -> IO ()-bringPaneToFront pane = do- let tv = getTopWidget pane- mbParent <- widgetGetParent tv- case mbParent of- Just parent -> do- let nb = castToNotebook parent- n <- notebookGetNPages nb- r <- filterM (\i -> do- mbp <- notebookGetNthPage nb i- case mbp of- Nothing -> return False- Just p -> do- mbs <- notebookGetTabLabelText nb p- case mbs of- Nothing -> return False- Just s -> return (s == paneName pane))- [0..(n-1)]- case r of- [i] -> notebookSetCurrentPage nb i- otherwise -> return ()- Nothing -> return ()------- | Get a valid panePath from a standard path.----getStandardPanePath :: StandardPath -> PaneLayout -> PanePath-getStandardPanePath sp pl = reverse $ getStandard' sp pl []- where- getStandard' _ (TerminalP _ _) p = p- getStandard' (LeftP:sp) (VerticalP l r _) p = getStandard' sp l (LeftP:p)- getStandard' (RightP:sp) (VerticalP l r _) p = getStandard' sp r (RightP:p)- getStandard' (TopP:sp) (HorizontalP t b _) p = getStandard' sp t (TopP:p)- getStandard' (BottomP:sp) (HorizontalP t b _) p = getStandard' sp b (BottomP:p)- -- if no match get leftmost topmost- getStandard' _ (VerticalP l r _) p = getStandard' [] l (LeftP:p)- getStandard' _ (HorizontalP t b _) p = getStandard' [] t (TopP:p)------- | Construct a new notebook----newNotebook :: IO Notebook-newNotebook = do- nb <- notebookNew- notebookSetTabPos nb PosTop- notebookSetShowTabs nb True- notebookSetScrollable nb True- notebookSetPopup nb True- return nb-------- | Get another pane path which points to the other side at the same level----otherSide :: PanePath -> Maybe PanePath-otherSide [] = Nothing-otherSide p = let rp = reverse p- ae = otherDirection $head rp- in Just (reverse $ae : tail rp)------- | Get the opposite direction of a pane direction----otherDirection :: PaneDirection -> PaneDirection-otherDirection LeftP = RightP-otherDirection RightP = LeftP-otherDirection TopP = BottomP-otherDirection BottomP = TopP------- | Get the layout at the given pane path----layoutFromPath :: PanePath -> PaneLayout -> PaneLayout-layoutFromPath [] l = l-layoutFromPath (TopP:r) (HorizontalP t _ _) = layoutFromPath r t-layoutFromPath (BottomP:r) (HorizontalP _ b _) = layoutFromPath r b-layoutFromPath (LeftP:r) (VerticalP l _ _) = layoutFromPath r l-layoutFromPath (RightP:r) (VerticalP _ ri _) = layoutFromPath r ri-layoutFromPath pp l = error- $"inconsistent layout " ++ show pp ++ " " ++ show l---getNotebookOrPaned :: PaneMonad alpha => PanePath -> (Widget -> beta) -> alpha beta-getNotebookOrPaned p cf = (widgetGet $["topBox","root"] ++ map paneDirectionToWidgetName p) cf------- | Get the notebook widget for the given pane path----getNotebook :: PaneMonad alpha => PanePath -> alpha Notebook-getNotebook p = getNotebookOrPaned p castToNotebook------- | Get the (gtk) Paned widget for a given path----getPaned :: PaneMonad alpha => PanePath -> alpha Paned-getPaned p = getNotebookOrPaned p castToPaned------- | Get the path to the active pane----getActivePanePath :: PaneMonad alpha => alpha (Maybe PanePath)-getActivePanePath = do- mbPane <- getActivePaneSt- case mbPane of- Nothing -> return Nothing- Just (paneName,_) -> do- (pp,_) <- guiPropertiesFromName paneName- return (Just (pp))--getActivePanePathOrStandard :: PaneMonad alpha => StandardPath -> alpha (PanePath)-getActivePanePathOrStandard sp = do- mbApp <- getActivePanePath- case mbApp of- Just app -> return app- Nothing -> do- layout <- getLayoutSt- return (getStandardPanePath sp layout)-------- | Get the active notebook----getActiveNotebook :: PaneMonad alpha => alpha (Maybe Notebook)-getActiveNotebook = do- mbPanePath <- getActivePanePath- case mbPanePath of- Just panePath -> do- nb <- getNotebook panePath- return (Just nb)- Nothing -> return Nothing-------- | Translates a pane direction to the widget name----paneDirectionToWidgetName :: PaneDirection -> String-paneDirectionToWidgetName TopP = "top"-paneDirectionToWidgetName BottomP = "bottom"-paneDirectionToWidgetName LeftP = "left"-paneDirectionToWidgetName RightP = "right"------- | Changes a pane path in the pane map----adjustPane :: PaneMonad alpha => PanePath -> PanePath -> alpha ()-adjustPane fromPane toPane = do- paneMap <- getPaneMapSt- let newMap = Map.map (\(pp,other) -> do- if pp == fromPane- then (toPane,other)- else (pp,other)) paneMap- setPaneMapSt newMap------- | Changes the layout for a split----adjustLayoutForSplit :: PaneMonad alpha => Direction -> PanePath -> alpha ()-adjustLayoutForSplit dir path = do- layout <- getLayoutSt- let newTerm = case dir of- Horizontal -> HorizontalP (TerminalP Nothing 0) (TerminalP Nothing 0) 0- Vertical -> VerticalP (TerminalP Nothing 0) (TerminalP Nothing 0) 0- setLayoutSt $ adjust path layout newTerm------- | Changes the layout for a collapse-----adjustLayoutForCollapse :: PaneMonad alpha => PanePath -> alpha ()-adjustLayoutForCollapse path = do- layout <- getLayoutSt- setLayoutSt $ adjust path layout (TerminalP Nothing 0)--getSubpath :: PanePath -> PaneLayout -> Maybe PanePath-getSubpath path layout =- case layoutFromPath path layout of- TerminalP _ _ -> Nothing- HorizontalP _ _ _ -> Just (path ++ [TopP])- VerticalP _ _ _ -> Just (path ++ [LeftP])------- | Changes the layout by replacing element at pane path with replace----adjust :: PanePath -> PaneLayout -> PaneLayout -> PaneLayout-adjust pp layout replace = adjust' pp layout- where- adjust' [] _ = replace- adjust' (TopP:r) (HorizontalP tp bp _) = HorizontalP (adjust' r tp) bp 0- adjust' (BottomP:r) (HorizontalP tp bp _) = HorizontalP tp (adjust' r bp) 0- adjust' (LeftP:r) (VerticalP lp rp _) = VerticalP (adjust' r lp) rp 0- adjust' (RightP:r) (VerticalP lp rp _) = VerticalP lp (adjust' r rp) 0- adjust' p l = error $"inconsistent layout " ++ show p ++ " " ++ show l------- | Get the widget from a list of strings----widgetFromPath :: Widget -> [String] -> IO (Widget)-widgetFromPath w [] = return w-widgetFromPath w (h:t) = do- children <- containerGetChildren (castToContainer w)- names <- mapM widgetGetName children- let mbiInd = findIndex (== h) names- case mbiInd of- Nothing -> error $"Cant't find widget path " ++ show (h:t)- Just ind -> widgetFromPath (children !! ind) t---widgetGet :: PaneMonad alpha => [String] -> (Widget -> b) -> alpha (b)-widgetGet strL cf = do- w <- getWindowSt- r <- liftIO $widgetFromPath (castToWidget w) strL- return (cf r)--widgetGetRel :: Widget -> [String] -> (Widget -> b) -> IO (b)-widgetGetRel w sl cf = do- r <- widgetFromPath w sl- return (cf r)--getUIAction :: PaneMonad alpha => String -> (Action -> a) -> alpha (a)-getUIAction str f = do- uiManager <- getUIManagerSt- liftIO $ do- findAction <- uiManagerGetAction uiManager str- case findAction of- Just act -> return (f act)- Nothing -> error $"getUIAction can't find action " ++ str+{-# OPTIONS_GHC+ -XFunctionalDependencies+ -XNoMonomorphismRestriction+ -XFlexibleInstances+ -XMultiParamTypeClasses+ -XUndecidableInstances+ -XDeriveDataTypeable #-}+-----------------------------------------------------------------------------+--+-- Module : IDE.Core.ViewFrame+-- Copyright : (c) Juergen Nicklisch-Franken, Hamish Mackenzie+-- License : GNU-GPL+--+-- Maintainer : <maintainer at leksah.org>+-- Stability : provisional+-- Portability : portable+--+--+-- | Splittable panes containing notebooks with any widgets+--+---------------------------------------------------------------------------------++module Graphics.UI.Frame.ViewFrame (+ removePaneAdmin+, addPaneAdmin+, notebookInsertOrdered+, markLabel++-- * Convenience methods for accesing Pane state+, posTypeToPaneDirection+, paneDirectionToPosType+, paneFromName+, mbPaneFromName+, guiPropertiesFromName++-- * View Actions+, viewMove+, viewSplitHorizontal+, viewSplitVertical+, viewSplit+, viewSplit'+, viewNewGroup+, newGroupOrBringToFront+, bringGroupToFront+, viewNest+, viewNest'+, viewDetach+, viewDetach'+, handleNotebookSwitch+, viewCollapse+, viewCollapse'+, viewTabsPos+, viewSwitchTabs++-- * View Queries+, getBestPanePath+, getBestPathForId+, getActivePanePath+, getActivePanePathOrStandard+, figureOutPaneName+, getNotebook+, getPaned+, getActiveNotebook+, getActivePane+, setActivePane+, getUiManager+, getWindows+, getMainWindow+, getLayout+, getPanesSt+, getPaneMapSt+, getPane+, getPanes++-- * View Actions+, bringPaneToFront+, newNotebook+, newNotebook'++-- * Accessing GUI elements+--, widgetFromPath+, getUIAction+, widgetGet+++) where++import Graphics.UI.Gtk hiding (afterToggleOverwrite,onToggleOverwrite)+import Control.Monad.Reader+import qualified Data.Map as Map+import Data.List+import Data.Maybe+import Data.Unique+import Data.Typeable++import Graphics.UI.Frame.Panes+import Graphics.UI.Editor.Parameters+import System.Glib (isA)+import Graphics.UI.Gtk.Types (gTypeNotebook)+import System.CPUTime (getCPUTime)+import Graphics.UI.Gtk.Gdk.Enums (Modifier(..))+import MyMissing+import Graphics.UI.Gtk.Gdk.EventM (TimeStamp(..))+import Graphics.UI.Editor.MakeEditor+ (mkField, FieldDescription(..), buildEditor)+import Graphics.UI.Editor.Simple (stringEditor, okCancelFields)+import Control.Event (registerEvent)+import Graphics.UI.Editor.Basics+ (eventPaneName, GUIEventSelector(..))+import qualified Data.Set as Set (unions, member)+import Data.Set (Set(..))+import Graphics.UI.Gtk.Gdk.Events (Event(..))+-- import Debug.Trace (trace)+trace a b = b++removePaneAdmin :: Pane alpha beta => alpha -> beta ()+removePaneAdmin pane = do+ panes' <- getPanesSt+ paneMap' <- getPaneMapSt+ setPanesSt (Map.delete (paneName pane) panes')+ setPaneMapSt (Map.delete (paneName pane) paneMap')++addPaneAdmin :: RecoverablePane alpha beta delta => alpha -> Connections -> PanePath -> delta ()+addPaneAdmin pane conn pp = do+ panes' <- getPanesSt+ paneMap' <- getPaneMapSt+ unique <- liftIO newUnique+ liftIO $ widgetSetName (getTopWidget pane) (paneName pane)+ trace ("addPaneAdmin name: " ++ paneName pane ++ " path: " ++ show pp) $+ setPaneMapSt (Map.insert (paneName pane) (pp, conn) paneMap')+ setPanesSt (Map.insert (paneName pane) (PaneC pane) panes')++getPane :: RecoverablePane alpha beta delta => delta (Maybe alpha)+getPane = do+ selectedPanes <- getPanes+ if null selectedPanes || length selectedPanes > 1+ then return Nothing+ else (return (Just $ head selectedPanes))++getPanes :: RecoverablePane alpha beta delta => delta ([alpha])+getPanes = do+ panes' <- getPanesSt+ return (catMaybes+ $ map (\(PaneC p) -> cast p)+ $ Map.elems panes')++notebookInsertOrdered :: PaneMonad alpha => (NotebookClass self, WidgetClass child) + => self + -> child -- child - the Widget to use as the contents of the page.+ -> String+ -> Maybe Label -- the label for the page as String or Label+ -> alpha ()+notebookInsertOrdered nb widget labelStr mbLabel = do+ label <- case mbLabel of+ Nothing -> liftIO $ labelNew (Just labelStr)+ Just l -> return l+ menuLabel <- liftIO $ labelNew (Just labelStr)+ numPages <- liftIO $ notebookGetNPages nb+ mbWidgets <- liftIO $ mapM (notebookGetNthPage nb) [0 .. (numPages-1)]+ -- trace ("numPages " ++ show numPages) $++ let widgets = map (\v -> forceJust v "ViewFrame.notebookInsertOrdered: no widget") mbWidgets+ labelStrs <- liftIO $ mapM (widgetGetName) widgets+ let pos = case findIndex (\s -> s > labelStr) labelStrs of+ Just i -> i+ Nothing -> -1+ labelBox <- mkLabelBox label labelStr+ liftIO $ do+ markLabel nb labelBox False+ realPos <- notebookInsertPageMenu nb widget labelBox menuLabel pos+ widgetShowAll labelBox+ notebookSetCurrentPage nb realPos++-- | Returns a label box+mkLabelBox :: PaneMonad alpha => Label -> String -> alpha EventBox+mkLabelBox lbl paneName = do+ (tb,lb) <- liftIO $ do+ miscSetAlignment (castToMisc lbl) 0.0 0.0+ miscSetPadding (castToMisc lbl) 0 0++ labelBox <- eventBoxNew+ eventBoxSetVisibleWindow labelBox False+ innerBox <- hBoxNew False 0++ tabButton <- buttonNew+ widgetSetName tabButton "leksah-close-button"+ buttonSetFocusOnClick tabButton False+ buttonSetRelief tabButton ReliefNone+ buttonSetAlignment tabButton (0.0,0.0)++ image <- imageNewFromStock stockClose IconSizeMenu+ mbPB <- widgetRenderIcon tabButton stockClose IconSizeMenu ""+ (height,width) <- case mbPB of+ Nothing -> trace "no real size" return (14,14)+ Just pb -> do+ h <- pixbufGetHeight pb+ w <- pixbufGetWidth pb+ return (h,w)+ on tabButton styleSet (\style -> do+ widgetSetSizeRequest tabButton (height + 2) (width + 2))+ containerSetBorderWidth tabButton 0+ containerAdd tabButton image++ boxPackStart innerBox lbl PackNatural 0+ boxPackEnd innerBox tabButton PackNatural 0++ containerAdd labelBox innerBox+ dragSourceSet labelBox [Button1] [ActionCopy,ActionMove]+ tl <- targetListNew+ targetListAddTextTargets tl 0+ dragSourceSetTargetList labelBox tl+ on labelBox dragDataGet (\ cont id timeStamp -> do+ selectionDataSetText paneName+ trace ("DragGet data: " ++ paneName) $ return ())+ return (tabButton,labelBox)+ cl <- runInIO closeHandler+ liftIO $ onClicked tb (cl ())++ return lb+ where+ closeHandler :: PaneMonad alpha => () -> alpha ()+ closeHandler _ = case "group_" `stripPrefix` paneName of+ Just group -> do+ closeGroup group+ Nothing -> do+ (PaneC pane) <- paneFromName paneName+ close pane+ return ()++-- | Add the change mark or removes it+markLabel :: (WidgetClass alpha, NotebookClass beta) => beta -> alpha -> Bool -> IO ()+markLabel nb topWidget modified = do+ mbBox <- notebookGetTabLabel nb topWidget+ case mbBox of+ Nothing -> return ()+ Just box -> do+ mbContainer <- binGetChild (castToBin box)+ case mbContainer of+ Nothing -> return ()+ Just container -> do+ children <- containerGetChildren container+ let label = castToLabel $ forceHead children "ViewFrame>>markLabel: empty children"+ text <- widgetGetName topWidget+ labelSetUseMarkup (castToLabel label) True+ labelSetMarkup (castToLabel label)+ (if modified+ then "<span foreground=\"red\">" ++ text ++ "</span>"+ else text)++-- | Constructs a unique pane name, which is an index and a string+figureOutPaneName :: PaneMonad alpha => String -> Int -> alpha (Int,String)+figureOutPaneName bn ind = do+ bufs <- getPanesSt+ let ind = foldr (\(PaneC buf) ind ->+ if primPaneName buf == bn+ then max ind ((getAddedIndex buf) + 1)+ else ind)+ 0 (Map.elems bufs)+ if ind == 0+ then return (0,bn)+ else return (ind,bn ++ "(" ++ show ind ++ ")")++paneFromName :: PaneMonad alpha => PaneName -> alpha (IDEPane alpha)+paneFromName pn = do+ mbPane <- mbPaneFromName pn+ case mbPane of+ Just p -> return p+ Nothing -> error $ "ViewFrame>>paneFromName:Can't find pane from unique name " ++ pn++mbPaneFromName :: PaneMonad alpha => PaneName -> alpha (Maybe (IDEPane alpha))+mbPaneFromName pn = do+ panes <- getPanesSt+ return (Map.lookup pn panes)++-- |+guiPropertiesFromName :: PaneMonad alpha => PaneName -> alpha (PanePath, Connections)+guiPropertiesFromName pn = do+ paneMap <- getPaneMapSt+ case Map.lookup pn paneMap of+ Just it -> return it+ otherwise -> error $"Cant't find guiProperties from unique name " ++ pn++posTypeToPaneDirection PosLeft = LeftP+posTypeToPaneDirection PosRight = RightP +posTypeToPaneDirection PosTop = TopP+posTypeToPaneDirection PosBottom = BottomP ++paneDirectionToPosType LeftP = PosLeft+paneDirectionToPosType RightP = PosRight +paneDirectionToPosType TopP = PosTop+paneDirectionToPosType BottomP = PosBottom++--+-- | Toggle the tabs of the current notebook+--+viewSwitchTabs :: PaneMonad alpha => alpha ()+viewSwitchTabs = do+ mbNb <- getActiveNotebook+ case mbNb of+ Nothing -> return ()+ Just nb -> liftIO $ do+ b <- notebookGetShowTabs nb+ notebookSetShowTabs nb (not b)++--+-- | Sets the tab position in the current notebook+--+viewTabsPos :: PaneMonad alpha => PositionType -> alpha ()+viewTabsPos pos = do+ mbNb <- getActiveNotebook+ case mbNb of+ Nothing -> return ()+ Just nb -> liftIO $notebookSetTabPos nb pos++--+-- | Split the currently active pane in horizontal direction+--+viewSplitHorizontal :: PaneMonad alpha => alpha ()+viewSplitHorizontal = viewSplit Horizontal++--+-- | Split the currently active pane in vertical direction+--+viewSplitVertical :: PaneMonad alpha => alpha ()+viewSplitVertical = viewSplit Vertical++--+-- | The active view can be split in two (horizontal or vertical)+--+viewSplit :: PaneMonad alpha => Direction -> alpha ()+viewSplit dir = do+ mbPanePath <- getActivePanePath+ case mbPanePath of+ Nothing -> return ()+ Just panePath -> do+ viewSplit' panePath dir++viewSplit' :: PaneMonad alpha => PanePath -> Direction -> alpha ()+viewSplit' panePath dir = do+ l <- getLayout+ case layoutFromPath panePath l of+ (TerminalP _ _ _ (Just _) _) -> trace ("ViewFrame>>viewSplit': can't split detached: ")+ return ()+ _ -> do+ activeNotebook <- getNotebook panePath+ mbPD <- do+ mbParent <- liftIO $ widgetGetParent activeNotebook+ case mbParent of+ Nothing -> trace ("ViewFrame>>viewSplit': parent not found: ") return Nothing+ Just parent -> do+ (nb,paneDir) <- do+ let (name,altname,paneDir,+ oldPath,newPath) = case dir of+ Horizontal -> ("top",+ "bottom",+ TopP,+ panePath ++ [SplitP TopP],+ panePath ++ [SplitP BottomP])+ Vertical -> ("left",+ "right",+ LeftP,+ panePath ++ [SplitP LeftP],+ panePath ++ [SplitP RightP])+ nb <- newNotebook newPath+ st <- getFrameState+ setFrameState st{panePathFromNB = Map.insert activeNotebook oldPath (panePathFromNB st)}+ (np,nbi) <- liftIO $ do+ newpane <- case dir of+ Horizontal -> do h <- vPanedNew+ return (castToPaned h)+ Vertical -> do v <- hPanedNew+ return (castToPaned v)+ rName <- widgetGetName activeNotebook+ widgetSetName newpane rName+ widgetSetName nb altname+ panedPack2 newpane nb True True+ nbIndex <- if parent `isA` gTypeNotebook+ then notebookPageNum (castToNotebook parent) activeNotebook+ else trace ("ViewFrame>>viewSplit': parent not a notebook: ") return Nothing+ containerRemove (castToContainer parent) activeNotebook+ widgetSetName activeNotebook name+ panedPack1 newpane activeNotebook True True+ return (newpane,nbIndex)+ case (reverse panePath, nbi) of+ (SplitP dir:_, _)+ | dir `elem` [TopP, LeftP] -> liftIO $ panedPack1 (castToPaned parent) np True True+ | otherwise -> liftIO $ panedPack2 (castToPaned parent) np True True+ (GroupP group:_, Just n) -> do+ liftIO $ notebookInsertPage (castToNotebook parent) np group n+ label <- groupLabel group+ liftIO $ notebookSetTabLabel (castToNotebook parent) np label+ label2 <- groupMenuLabel group+ liftIO $ notebookSetMenuLabel (castToNotebook parent) np label2+ return ()+ ([], _) -> do+ liftIO $ boxPackStart (castToBox parent) np PackGrow 0+ liftIO $ boxReorderChild (castToVBox parent) np 2+ _ -> error "No notebook index found in viewSplit"+ liftIO $ do+ widgetShowAll np+ widgetGrabFocus activeNotebook+ case nbi of+ Just n -> do+ notebookSetCurrentPage (castToNotebook parent) n+ return ()+ _ -> trace ("ViewFrame>>viewSplit': parent not a notebook: ")return ()+ return (nb,paneDir)+ handleFunc <- runInIO (handleNotebookSwitch nb)+ liftIO $ afterSwitchPage nb handleFunc+ return (Just (paneDir,dir))+ case mbPD of+ Just (paneDir,pdir) -> do+ let toPane = panePath ++ [SplitP paneDir]+ adjustPanes panePath toPane+ adjustLayoutForSplit paneDir panePath+ viewMove (otherDirection paneDir)+ Nothing -> return ()++viewNewGroup :: PaneMonad alpha => alpha ()+viewNewGroup = do+ mainWindow <- getMainWindow+ mbGroupName <- liftIO $ groupNameDialog mainWindow+ case+ mbGroupName of+ Just groupName -> do+ layout <- getLayoutSt+ if groupName `Set.member` allGroupNames layout+ then liftIO $ do+ md <- messageDialogNew (Just mainWindow) [] MessageWarning ButtonsClose+ ("Group name not unique " ++ groupName)+ dialogRun md+ widgetDestroy md+ return ()+ else viewNest groupName+ Nothing -> return ()++newGroupOrBringToFront :: PaneMonad alpha => String -> PanePath -> alpha (Maybe PanePath,Bool)+newGroupOrBringToFront groupName pp = do+ layout <- getLayoutSt+ if groupName `Set.member` allGroupNames layout+ then do+ mbPP <- bringGroupToFront groupName+ return (mbPP,False)+ else let realPath = getBestPanePath pp layout in do+ viewNest' realPath groupName+ return (Just (realPath ++ [GroupP groupName]),True)++bringGroupToFront :: PaneMonad alpha => String -> alpha (Maybe PanePath)+bringGroupToFront groupName = do+ layout <- getLayoutSt+ case findGroupPath groupName layout of+ Just path -> do+ widget <- getNotebookOrPaned path castToWidget+ liftIO $ setCurrentNotebookPages widget+ return (Just path)+ Nothing -> return Nothing+++-- Yet another stupid little dialog++groupNameDialog :: Window -> IO (Maybe String)+groupNameDialog parent = liftIO $ do+ dia <- dialogNew+ windowSetTransientFor dia parent+ windowSetTitle dia "Enter group name"+ upper <- dialogGetUpper dia+ lower <- dialogGetActionArea dia+ (widget,inj,ext,_) <- buildEditor moduleFields ""+ (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+ case resp of+ ResponseOk | value /= Just "" -> return value+ _ -> return Nothing+ where+ moduleFields :: FieldDescription String+ moduleFields = VFD emptyParams [+ mkField+ (paraName <<<- ParaName ("New group ")+ $ emptyParams)+ id+ (\ a b -> a)+ (stringEditor (\s -> True))]++viewNest :: PaneMonad alpha => String -> alpha ()+viewNest group = do+ mbPanePath <- getActivePanePath+ case mbPanePath of+ Nothing -> return ()+ Just panePath -> do+ viewNest' panePath group++viewNest' :: PaneMonad alpha => PanePath -> String -> alpha ()+viewNest' panePath group = do+ activeNotebook <- getNotebook panePath+ mbParent <- liftIO $ widgetGetParent activeNotebook+ case mbParent of+ Nothing -> return ()+ Just parent -> do+ layout <- getLayoutSt+ let paneLayout = layoutFromPath panePath layout+ case paneLayout of+ (TerminalP {}) -> do+ nb <- newNotebook (panePath ++ [GroupP group])+ liftIO $ do+ widgetSetName nb ("group_" ++ group)+ notebookAppendPage activeNotebook nb group+ label <- groupLabel group+ label2 <- groupMenuLabel group+ liftIO $ do+ notebookSetTabLabel activeNotebook nb label+ notebookSetMenuLabel activeNotebook nb label2+ widgetShowAll nb+ widgetGrabFocus activeNotebook+ return nb+ handleFunc <- runInIO (handleNotebookSwitch nb)+ liftIO $ afterSwitchPage nb handleFunc+ adjustLayoutForNest group panePath+ _ -> return ()++closeGroup :: PaneMonad alpha => String -> alpha ()+closeGroup groupName = do+ layout <- getLayout+ let mbPath = findGroupPath groupName layout+ mainWindow <- getMainWindow+ case mbPath of+ Nothing -> trace ("ViewFrame>>closeGroup: Group path not found: " ++ groupName) return ()+ Just path -> do+ panesMap <- getPaneMapSt+ let nameAndpathList = filter (\(a,pp) -> path `isPrefixOf` pp)+ $ map (\(a,b) -> (a,fst b)) (Map.assocs panesMap)+ continue <- case nameAndpathList of+ (_:_) -> liftIO $ do+ md <- messageDialogNew (Just mainWindow) [] MessageQuestion ButtonsYesNo+ ("Group " ++ groupName ++ " not empty. Close with all contents?")+ rid <- dialogRun md+ widgetDestroy md+ case rid of+ ResponseYes -> return True+ otherwise -> return False+ [] -> return True+ when continue $ do+ panes <- mapM paneFromName $ map fst nameAndpathList+ results <- mapM (\ (PaneC p) -> close p) panes+ when (foldr (&&) True results) $ do+ nbOrPaned <- getNotebookOrPaned path castToWidget+ mbParent <- liftIO $ widgetGetParent nbOrPaned+ case mbParent of+ Nothing -> error "ViewFrame>>closeGroup: closeGroup: no parent"+ Just parent -> liftIO $ containerRemove (castToContainer parent) nbOrPaned+ setLayoutSt (removeGL path layout)+ ppMap <- getPanePathFromNB+ setPanePathFromNB (Map.filter (\pa -> path `isPrefixOf` pa) ppMap)+ return ()++viewDetach :: PaneMonad alpha => alpha (Maybe (Window,Widget))+viewDetach = do+ id <- liftIO $ fmap show getCPUTime+ mbPanePath <- getActivePanePath+ case mbPanePath of+ Nothing -> return Nothing+ Just panePath -> do+ viewDetach' panePath id++viewDetach' :: PaneMonad alpha => PanePath -> String -> alpha (Maybe (Window,Widget))+viewDetach' panePath id = do+ activeNotebook <- getNotebook panePath+ mbParent <- liftIO $ widgetGetParent activeNotebook+ case mbParent of+ Nothing -> return Nothing+ Just parent -> do+ layout <- getLayoutSt+ let paneLayout = layoutFromPath panePath layout+ case paneLayout of+ (TerminalP{detachedSize = size}) -> do+ window <- liftIO $ do+ window <- windowNew+ windowSetTitle window "leksah detached window"+ widgetSetName window id+ case size of+ Just (width, height) -> do+ windowSetDefaultSize window width height+ Nothing -> do+ (curWidth, curHeight) <- widgetGetSize activeNotebook+ windowSetDefaultSize window curWidth curHeight+ containerRemove (castToContainer parent) activeNotebook+ containerAdd window activeNotebook+ widgetShowAll window+ return window+ handleFunc <- runInIO (handleReattach id window)+ liftIO $ window `onDelete` handleFunc+ windows <- getWindowsSt+ setWindowsSt $ windows ++ [window]+ adjustLayoutForDetach id panePath+ return (Just (window, castToWidget activeNotebook))+ _ -> return Nothing++++handleReattach :: PaneMonad alpha => String -> Window -> Event -> alpha Bool+handleReattach windowId window _ = do+ layout <- getLayout+ case findDetachedPath windowId layout of+ Nothing -> trace ("ViewFrame>>handleReattach: panePath for id not found: " ++ windowId)+ $ do+ windows <- getWindowsSt+ setWindowsSt $ delete window windows+ return False+ Just pp -> do+ nb <- getNotebook pp+ parent <- getNotebookOrPaned (init pp) castToContainer+ liftIO $ containerRemove (castToContainer window) nb+ liftIO $ containerAdd parent nb+ adjustLayoutForReattach pp+ windows <- getWindowsSt+ setWindowsSt $ delete window windows+ case last pp of+ GroupP groupName -> do+ label <- groupLabel groupName+ liftIO $ notebookSetTabLabel (castToNotebook parent) nb label+ otherwise -> return ()+ return False -- "now destroy the window"++groupLabel :: PaneMonad beta => String -> beta EventBox+groupLabel group = do+ label <- liftIO $ labelNew Nothing+ liftIO $ labelSetUseMarkup label True+ liftIO $ labelSetMarkup label ("<b>" ++ group ++ "</b>")+ labelBox <- mkLabelBox label ("group_" ++ group)+ liftIO $ widgetShowAll labelBox+ return labelBox++groupMenuLabel :: PaneMonad beta => String -> beta (Maybe Label)+groupMenuLabel group = liftM Just (liftIO $ labelNew (Just group))++handleNotebookSwitch :: PaneMonad beta => Notebook -> Int -> beta ()+handleNotebookSwitch nb index = do+ mbW <- liftIO $ notebookGetNthPage nb index+ case mbW of+ Nothing -> error "ViewFrame/handleNotebookSwitch: Can't find widget"+ Just w -> do+ name <- liftIO $ widgetGetName w+ mbPane <- findPaneFor name+ case mbPane of+ Nothing -> return () -- trace ("ViewFrame>>handleNotebookSwitch: can't find pane " ++ name)++ Just (PaneC p) -> makeActive p -- trace ("ViewFrame>>handleNotebookSwitch: switch to pane " ++ name)++ where+ findPaneFor :: PaneMonad beta => String -> beta (Maybe (IDEPane beta))+ findPaneFor n1 = do+ panes' <- getPanesSt+ foldM (\r (PaneC p) -> do+ n2 <- liftIO $ widgetGetName (getTopWidget p)+ return (if n1 == n2 then (Just (PaneC p)) else r))+ Nothing (Map.elems panes')++--+-- | Two notebooks can be collapsed to one+--+viewCollapse :: PaneMonad alpha => alpha ()+viewCollapse = do+ mbPanePath <- getActivePanePath+ case mbPanePath of+ Nothing -> return ()+ Just panePath -> do+ viewCollapse' panePath++viewCollapse' :: PaneMonad alpha => PanePath -> alpha ()+viewCollapse' panePath = do+ trace ("Collapse : " ++ (show panePath)) $ return ()+ layout1 <- getLayoutSt+ case layoutFromPath panePath layout1 of+ (TerminalP _ _ _ (Just _) _) -> trace ("ViewFrame>>viewCollapse': can't collapse detached: ")+ return ()+ _ -> do+ let newPanePath = init panePath+ let mbOtherSidePath = otherSide panePath+ case mbOtherSidePath of+ Nothing -> return ()+ Just otherSidePath ->+ let sp1 = getGroupPathForCollapse panePath layout1+ sp2 = getGroupPathForCollapse otherSidePath layout1+ in do+ case sp1 of+ Nothing -> return ()+ Just sp -> viewCollapse' sp+ case sp2 of+ Nothing -> return ()+ Just sp -> viewCollapse' sp+ paneMap <- getPaneMapSt+ activeNotebook <- getNotebook panePath+ st <- getFrameState+ otherSideNotebook <- getNotebook otherSidePath+ setFrameState st{panePathFromNB = (Map.delete otherSideNotebook+ (Map.insert activeNotebook newPanePath (panePathFromNB st)))}+ let paneNamesToMove = map (\(w,(p,_)) -> w)+ $filter (\(w,(p,_)) -> otherSidePath `isPrefixOf` p)+ $Map.toList paneMap+ panesToMove <- mapM paneFromName paneNamesToMove+ mapM_ (\(PaneC p) -> move panePath p) panesToMove+ mbParent <- liftIO $ widgetGetParent activeNotebook+ case mbParent of+ Nothing -> error "collapse: no parent"+ Just parent -> do+ mbGrandparent <- liftIO $ widgetGetParent parent+ case mbGrandparent of+ Nothing -> error "collapse: no grandparent"+ Just grandparent -> do+ nbIndex <- if grandparent `isA` gTypeNotebook+ then liftIO $ notebookPageNum (castToNotebook grandparent) parent+ else return Nothing+ liftIO $ containerRemove (castToContainer grandparent) parent+ liftIO $ containerRemove (castToContainer parent) activeNotebook+ if length panePath > 1+ then do+ let lasPathElem = last newPanePath+ case (lasPathElem, nbIndex) of+ (SplitP dir, _) | dir == TopP || dir == LeftP ->+ liftIO $ panedPack1 (castToPaned grandparent) activeNotebook True True+ (SplitP dir, _) | dir == BottomP || dir == RightP ->+ liftIO $ panedPack2 (castToPaned grandparent) activeNotebook True True+ (GroupP group, Just n) -> do+ liftIO $ notebookInsertPage (castToNotebook grandparent) activeNotebook group n+ label <- groupLabel group+ liftIO $ do+ notebookSetTabLabel (castToNotebook grandparent) activeNotebook label+ notebookSetCurrentPage (castToNotebook grandparent) n+ return ()+ _ -> error "collapse: Unable to find page index"+ liftIO $ widgetSetName activeNotebook $panePathElementToWidgetName lasPathElem+ else liftIO $ do+ boxPackStart (castToVBox grandparent) activeNotebook PackGrow 0+ boxReorderChild (castToVBox grandparent) activeNotebook 2+ widgetSetName activeNotebook "root"+ adjustPanes panePath newPanePath+ adjustPanes otherSidePath newPanePath+ adjustLayoutForCollapse panePath++getGroupPathForCollapse :: PanePath -> PaneLayout -> Maybe PanePath+getGroupPathForCollapse path layout =+ case layoutFromPath path layout of+ TerminalP {} -> Nothing+ HorizontalP _ _ _ -> Just (path ++ [SplitP TopP])+ VerticalP _ _ _ -> Just (path ++ [SplitP LeftP])++++--+-- | Moves the activePane in the given direction, if possible+-- | If their are many possibilities choose the leftmost and topmost+--+viewMove :: PaneMonad beta => PaneDirection -> beta ()+viewMove direction = do+ mbPane <- getActivePaneSt+ case mbPane of+ Nothing -> do+ return ()+ Just (paneName,_) -> do+ (PaneC pane) <- paneFromName paneName+ mbPanePath <- getActivePanePath+ case mbPanePath of+ Nothing -> do+ return ()+ Just panePath -> do+ layout <- getLayoutSt+ case findMoveTarget panePath layout direction of+ Nothing -> do+ return ()+ Just moveTo -> move moveTo pane++--+-- | Find the target for a move+--+findMoveTarget :: PanePath -> PaneLayout -> PaneDirection -> Maybe PanePath+findMoveTarget panePath layout direction=+ let oppositeDir = otherDirection direction+ canMove [] = []+ canMove reversedPath =+ case head reversedPath of+ SplitP d | d == oppositeDir+ -> SplitP direction : (tail reversedPath)+ GroupP group -> []+ _ -> canMove (tail reversedPath)+ basePath = reverse (canMove $ reverse panePath)+ in case basePath of+ [] -> Nothing+ _ -> let layoutP = layoutFromPath basePath layout+ in trace (show basePath) Just $basePath ++ findAppropriate layoutP oppositeDir++dragMove :: PaneMonad alpha => (PaneName,Notebook) -> alpha ()+dragMove (paneName,toNB) = do+ paneMap <- getPaneMapSt+ panes <- getPanesSt+ layout <- getLayout+ frameState <- getFrameState+ case "group_" `stripPrefix` paneName of+ Just group -> do+ trace ("dragMove a group Layout before: " ++ show layout) return ()+ case findGroupPath group layout of+ Nothing -> trace ("ViewFrame>>dragMove: group not found: " ++ group) return ()+ Just fromPath -> do+ groupNBOrPaned <- getNotebookOrPaned fromPath castToWidget+ fromNB <- getNotebook (init fromPath)+ case toNB `Map.lookup` (panePathFromNB frameState) of+ Nothing -> trace "ViewFrame>>dragMove: panepath for Notebook not found" return ()+ Just toPath -> do+ when (fromNB /= toNB && not (isPrefixOf fromPath toPath)) $ do+ mbNum <- liftIO $ notebookPageNum fromNB groupNBOrPaned+ case mbNum of+ Nothing -> trace "ViewFrame>>dragMove: group notebook not found" return ()+ Just num -> do+ liftIO $ notebookRemovePage fromNB num+ label <- groupLabel group+ notebookInsertOrdered toNB groupNBOrPaned group Nothing+ liftIO $ notebookSetTabLabel toNB groupNBOrPaned label+ adjustPanes fromPath (toPath ++ [GroupP group])+ adjustLayoutForGroupMove fromPath toPath group+ adjustNotebooks fromPath (toPath ++ [GroupP group])+ layout2 <- getLayout+ trace ("dragMove a group Layout after: " ++ show layout2) return ()+ return ()+ Nothing ->+ case paneName `Map.lookup` panes of+ Nothing -> trace ("ViewFrame>>dragMove: pane not found: " ++ paneName) return ()+ Just (PaneC pane) -> do+ case toNB `Map.lookup` (panePathFromNB frameState) of+ Nothing -> trace "ViewFrame>>dragMove: panepath for Notebook not found" return ()+ Just toPath ->+ case paneName `Map.lookup`paneMap of+ Nothing -> trace ("ViewFrame>>dragMove: pane data not found: " ++ paneName)+ return ()+ Just (fromPath,_) -> do+ let child = getTopWidget pane+ (fromPane,cid) <- guiPropertiesFromName paneName+ fromNB <- trace ("dragMove: pane name: " ++ paneName ++ " path: " ++ show fromPane)+ getNotebook fromPane+ when (fromNB /= toNB) $ do+ mbNum <- liftIO $ notebookPageNum fromNB child+ case mbNum of+ Nothing -> trace "ViewFrame>>dragMove: widget not found" return ()+ Just num -> do+ liftIO $ notebookRemovePage fromNB num+ notebookInsertOrdered toNB child paneName Nothing+ let paneMap1 = Map.delete paneName paneMap+ trace ("drag move name: " ++ paneName ++ " path: " ++ show toPath) $+ setPaneMapSt $ Map.insert paneName (toPath,cid) paneMap1++--+-- | Moves the given Pane to the given path+-- TODO use adjust+move :: Pane alpha beta => PanePath -> alpha -> beta ()+move toPane idew = do+ paneMap <- getPaneMapSt+ let child = getTopWidget idew+ (fromPane,cid) <- guiPropertiesFromName (paneName idew)+ fromNB <- getNotebook fromPane+ toNB <- getNotebook toPane+ mbNum <- liftIO $ notebookPageNum fromNB child+ case mbNum of+ Nothing -> return ()+ Just pn -> do+ mbBox <- liftIO $ notebookGetTabLabel fromNB child+ theText <- liftIO $ widgetGetName child+ liftIO $ notebookRemovePage fromNB pn+ notebookInsertOrdered toNB child theText Nothing+ let paneMap1 = Map.delete (paneName idew) paneMap+ trace ("move name: " ++ (paneName idew) ++ " path: " ++ show toPane) $+ setPaneMapSt $ Map.insert (paneName idew) (toPane,cid) paneMap1++findAppropriate :: PaneLayout -> PaneDirection -> PanePath+findAppropriate (TerminalP {}) _ = []+findAppropriate (HorizontalP t b _) LeftP = SplitP TopP : findAppropriate t LeftP+findAppropriate (HorizontalP t b _) RightP = SplitP TopP : findAppropriate t RightP+findAppropriate (HorizontalP t b _) BottomP = SplitP BottomP : findAppropriate b BottomP+findAppropriate (HorizontalP t b _) TopP = SplitP TopP : findAppropriate b TopP+findAppropriate (VerticalP l r _) LeftP = SplitP LeftP : findAppropriate l LeftP+findAppropriate (VerticalP l r _) RightP = SplitP RightP : findAppropriate r RightP+findAppropriate (VerticalP l r _) BottomP = SplitP LeftP : findAppropriate l BottomP+findAppropriate (VerticalP l r _) TopP = SplitP LeftP : findAppropriate l TopP++--+-- | Bring the pane to the front position in its notebook+--+bringPaneToFront :: Pane alpha beta => alpha -> IO ()+bringPaneToFront pane = do+ let tv = getTopWidget pane+ setCurrentNotebookPages tv+++setCurrentNotebookPages widget = do+ mbParent <- widgetGetParent widget+ case mbParent of+ Just parent -> do+ setCurrentNotebookPages parent+ if parent `isA` gTypeNotebook+ then do+ mbPageNum <- notebookPageNum (castToNotebook parent) widget+ case mbPageNum of+ Just pageNum -> do+ notebookSetCurrentPage (castToNotebook parent) pageNum+ return ()+ Nothing -> return ()+ else return ()+ Nothing -> return ()+ --do -- TODO use this?+ -- widgetShowAll widget+ -- windowPresent (castToWindow widget)++--+-- | Get a valid panePath from a standard path.+--+getBestPanePath :: StandardPath -> PaneLayout -> PanePath+getBestPanePath sp pl = let res = reverse $ getStandard' sp pl []+ in trace ("ViewFrame>>getBestPanePath in: " ++ show sp ++ " out: " ++ show res) res+ where+ getStandard' (GroupP group:sp) (TerminalP {paneGroups = groups}) p+ | group `Map.member` groups = getStandard' sp (groups Map.! group) (GroupP group:p)+ getStandard' _ (TerminalP {}) p = p+ getStandard' (SplitP LeftP:sp) (VerticalP l r _) p = getStandard' sp l (SplitP LeftP:p)+ getStandard' (SplitP RightP:sp) (VerticalP l r _) p = getStandard' sp r (SplitP RightP:p)+ getStandard' (SplitP TopP:sp) (HorizontalP t b _) p = getStandard' sp t (SplitP TopP:p)+ getStandard' (SplitP BottomP:sp) (HorizontalP t b _) p = getStandard' sp b (SplitP BottomP:p)+ -- if no match get leftmost topmost+ getStandard' _ (VerticalP l r _) p = getStandard' [] l (SplitP LeftP:p)+ getStandard' _ (HorizontalP t b _) p = getStandard' [] t (SplitP TopP:p)++--+-- | Get a standard path.+--+getBestPathForId :: PaneMonad alpha => String -> alpha PanePath+getBestPathForId id = do+ p <- panePathForGroup id+ l <- getLayout+ return (getBestPanePath p l)+ +--+-- | Construct a new notebook+--+newNotebook' :: IO Notebook+newNotebook' = do+ nb <- notebookNew+ notebookSetTabPos nb PosTop+ notebookSetShowTabs nb True+ notebookSetScrollable nb True+ notebookSetPopup nb True+ return nb++--+-- | Construct a new notebook,+--+newNotebook :: PaneMonad alpha => PanePath -> alpha Notebook+newNotebook pp = do+ st <- trace ("newNotebook path: " ++ show pp)+ getFrameState+ nb <- liftIO newNotebook'+ setFrameState st{panePathFromNB = Map.insert nb pp (panePathFromNB st)}+ func <- runInIO (dragMove)+ liftIO $ do+ tl <- targetListNew+ targetListAddTextTargets tl 0+ dragDestSet nb [DestDefaultAll] [ActionCopy, ActionMove]+ dragDestSetTargetList nb tl+ on nb dragDataReceived (dragFunc nb func)+ return nb+ where+ dragFunc ::+ Notebook ->+ ((PaneName,Notebook) -> IO ()) ->+ DragContext ->+ Point ->+ InfoId ->+ TimeStamp ->+ (SelectionDataM ())+ dragFunc nb func cont point id timeStamp = do+ mbText <- selectionDataGetText+ case mbText of+ Nothing -> return ()+ Just str -> do+ liftIO $ func (str,nb)+ return ()++terminalsWithPanePath :: PaneLayout -> [(PanePath,PaneLayout)]+terminalsWithPanePath pl = map (\ (pp,l) -> (reverse pp,l)) $ terminalsWithPP [] pl+ where+ terminalsWithPP pp t@(TerminalP groups _ _ _ _) = [(pp,t)]+ ++ concatMap (terminalsFromGroup pp) (Map.toList groups)+ terminalsWithPP pp (VerticalP l r _) = terminalsWithPP (SplitP LeftP : pp) l+ ++ terminalsWithPP (SplitP RightP : pp) r+ terminalsWithPP pp (HorizontalP t b _) = terminalsWithPP (SplitP TopP : pp) t+ ++ terminalsWithPP (SplitP BottomP : pp) b+ terminalsFromGroup pp (name,layout) = terminalsWithPP (GroupP name : pp) layout++findGroupPath :: String -> PaneLayout -> Maybe PanePath+findGroupPath group layout =+ let terminalPairs = terminalsWithPanePath layout+ in case (filter filterFunc terminalPairs) of+ [] -> Nothing+ (pp,_) : [] -> Just (pp ++ [GroupP group])+ _ -> error ("ViewFrame>>group name not unique: " ++ group)+ where+ filterFunc (_,(TerminalP groups _ _ _ _)) = group `Set.member` Map.keysSet groups+ filterFunc _ = error "ViewFrame>>findGroupPath: impossible"++findDetachedPath :: String -> PaneLayout -> Maybe PanePath+findDetachedPath id layout =+ let terminalPairs = terminalsWithPanePath layout+ in case (filter filterFunc terminalPairs) of+ [] -> Nothing+ (pp,_) : [] -> Just pp+ _ -> error ("ViewFrame>>window id not unique: " ++ id)+ where+ filterFunc (_,(TerminalP _ _ _ (Just lid) _)) = lid == id+ filterFunc _ = False+++allGroupNames :: PaneLayout -> Set String+allGroupNames pl = Set.unions $ map getFunc (terminalsWithPanePath pl)+ where+ getFunc (_,(TerminalP groups _ _ _ _)) = Map.keysSet groups+ getFunc _ = error "ViewFrame>>allGroupNames: impossible"+++--+-- | Get another pane path which points to the other side at the same level+--+otherSide :: PanePath -> Maybe PanePath+otherSide [] = Nothing+otherSide p = let rp = reverse p+ in case head rp of+ SplitP d -> Just (reverse $ SplitP (otherDirection d) : tail rp)+ _ -> Nothing++--+-- | Get the opposite direction of a pane direction+--+otherDirection :: PaneDirection -> PaneDirection+otherDirection LeftP = RightP+otherDirection RightP = LeftP+otherDirection TopP = BottomP+otherDirection BottomP = TopP++--+-- | Get the layout at the given pane path+--+layoutFromPath :: PanePath -> PaneLayout -> PaneLayout+layoutFromPath [] l = l+layoutFromPath (GroupP group:r) (TerminalP {paneGroups = groups})+ | group `Map.member` groups = layoutFromPath r (groups Map.! group)+layoutFromPath (SplitP TopP:r) (HorizontalP t _ _) = layoutFromPath r t+layoutFromPath (SplitP BottomP:r) (HorizontalP _ b _) = layoutFromPath r b+layoutFromPath (SplitP LeftP:r) (VerticalP l _ _) = layoutFromPath r l+layoutFromPath (SplitP RightP:r) (VerticalP _ ri _) = layoutFromPath r ri+layoutFromPath pp l = error+ $"inconsistent layout (layoutFromPath) " ++ show pp ++ " " ++ show l++layoutsFromPath :: PanePath -> PaneLayout -> [PaneLayout]+layoutsFromPath (GroupP group:r) layout@(TerminalP {paneGroups = groups})+ | group `Map.member` groups+ = layout:layoutsFromPath r (groups Map.! group)+layoutsFromPath [] layout = [layout]+layoutsFromPath (SplitP TopP:r) layout@(HorizontalP t b _) = layout:layoutsFromPath r t+layoutsFromPath (SplitP BottomP:r) layout@(HorizontalP t b _) = layout:layoutsFromPath r b+layoutsFromPath (SplitP LeftP:r) layout@(VerticalP l ri _) = layout:layoutsFromPath r l+layoutsFromPath (SplitP RightP:r) layout@(VerticalP l ri _) = layout:layoutsFromPath r ri+layoutsFromPath pp l = error+ $"inconsistent layout (layoutsFromPath) " ++ show pp ++ " " ++ show l++getWidgetNameList :: PanePath -> PaneLayout -> [String]+getWidgetNameList path layout = reverse $ nameList (reverse path) (reverse $ layoutsFromPath path layout)+ where+ nameList [] _ = reverse ["Leksah Main Window","topBox","root"]+ nameList (pe:_) (TerminalP{detachedId = Just id}:_) = [panePathElementToWidgetName pe, id]+ nameList (pe:rpath) (_:rlayout) = panePathElementToWidgetName pe : nameList rpath rlayout+ nameList _ _ = error $ "inconsistent layout (getWidgetNameList) " ++ show path ++ " " ++ show layout++getNotebookOrPaned :: PaneMonad alpha => PanePath -> (Widget -> beta) -> alpha beta+getNotebookOrPaned p cf = do+ layout <- getLayout+ (widgetGet $ getWidgetNameList p layout) cf++--+-- | Get the notebook widget for the given pane path+--+getNotebook :: PaneMonad alpha => PanePath -> alpha Notebook+getNotebook p = getNotebookOrPaned p castToNotebook++--+-- | Get the (gtk) Paned widget for a given path+--+getPaned :: PaneMonad alpha => PanePath -> alpha Paned+getPaned p = getNotebookOrPaned p castToPaned++--+-- | Get the path to the active pane+--+getActivePanePath :: PaneMonad alpha => alpha (Maybe PanePath)+getActivePanePath = do+ mbPane <- getActivePaneSt+ case mbPane of+ Nothing -> return Nothing+ Just (paneName,_) -> do+ (pp,_) <- guiPropertiesFromName paneName+ return (Just (pp))++getActivePanePathOrStandard :: PaneMonad alpha => StandardPath -> alpha (PanePath)+getActivePanePathOrStandard sp = do+ mbApp <- getActivePanePath+ case mbApp of+ Just app -> return app+ Nothing -> do+ layout <- getLayoutSt+ return (getBestPanePath sp layout)++--+-- | Get the active notebook+--+getActiveNotebook :: PaneMonad alpha => alpha (Maybe Notebook)+getActiveNotebook = do+ mbPanePath <- getActivePanePath+ case mbPanePath of+ Just panePath -> do+ nb <- getNotebook panePath+ return (Just nb)+ Nothing -> return Nothing+++--+-- | Translates a pane direction to the widget name+--+paneDirectionToWidgetName :: PaneDirection -> String+paneDirectionToWidgetName TopP = "top"+paneDirectionToWidgetName BottomP = "bottom"+paneDirectionToWidgetName LeftP = "left"+paneDirectionToWidgetName RightP = "right"++panePathElementToWidgetName :: PanePathElement -> String+panePathElementToWidgetName (SplitP dir) = paneDirectionToWidgetName dir+panePathElementToWidgetName (GroupP group) = "group_" ++ group++--+-- | Changes a pane path in the pane map+--+adjustPanes :: PaneMonad alpha => PanePath -> PanePath -> alpha ()+adjustPanes fromPane toPane = do+ trace ("adjustPanes: " ++ show fromPane ++ " -> " ++ show toPane) $ return ()+ paneMap <- getPaneMapSt+ setPaneMapSt (Map.map (\(pp,other) ->+ case stripPrefix fromPane pp of+ Just rest -> (toPane++rest,other)+ _ -> (pp,other)) paneMap)++adjustNotebooks :: PaneMonad alpha => PanePath -> PanePath -> alpha ()+adjustNotebooks fromPane toPane = do+ npMap <- getPanePathFromNB+ setPanePathFromNB (Map.map (\pp ->+ case stripPrefix fromPane pp of+ Just rest -> toPane++rest+ _ -> pp) npMap)++--+-- | Changes the layout for a split+--+adjustLayoutForSplit :: PaneMonad alpha => PaneDirection -> PanePath -> alpha ()+adjustLayoutForSplit dir path = do+ layout <- getLayoutSt+ let paneLayout = layoutFromPath path layout+ newLayout = TerminalP Map.empty Nothing 0 Nothing Nothing+ newTerm = case dir of+ LeftP -> VerticalP paneLayout newLayout 0+ RightP -> VerticalP newLayout paneLayout 0+ TopP -> HorizontalP paneLayout newLayout 0+ BottomP -> HorizontalP newLayout paneLayout 0+ setLayoutSt $ adjustLayout path layout newTerm++--+-- | Changes the layout for a nest+--+adjustLayoutForNest :: PaneMonad alpha => String -> PanePath -> alpha ()+adjustLayoutForNest group path = do+ layout <- getLayoutSt+ let paneLayout = layoutFromPath path layout+ newTerm = case paneLayout of+ (TerminalP {paneGroups = groups}) -> paneLayout {+ paneGroups = Map.insert group (TerminalP Map.empty Nothing 0 Nothing Nothing) groups}+ _ -> error "Unexpected layout type in adjustLayoutForNest"+ setLayoutSt $ adjustLayout path layout newTerm++--+-- | Changes the layout for a detach+--+adjustLayoutForDetach :: PaneMonad alpha => String -> PanePath -> alpha ()+adjustLayoutForDetach id path = do+ layout <- getLayoutSt+ let paneLayout = layoutFromPath path layout+ newTerm = case paneLayout of+ (TerminalP {}) -> paneLayout {detachedId = Just id}+ _ -> error "Unexpected layout type in adjustLayoutForDetach"+ setLayoutSt $ adjustLayout path layout newTerm++--+-- | Changes the layout for a reattach+--+adjustLayoutForReattach :: PaneMonad alpha => PanePath -> alpha ()+adjustLayoutForReattach path = do+ layout <- getLayoutSt+ let paneLayout = layoutFromPath path layout+ newTerm = case paneLayout of+ (TerminalP {}) -> paneLayout {detachedId = Nothing, detachedSize = Nothing}+ _ -> error "Unexpected layout type in adjustLayoutForReattach"+ setLayoutSt $ adjustLayout path layout newTerm++--+-- | Changes the layout for a collapse+--+adjustLayoutForCollapse :: PaneMonad alpha => PanePath -> alpha ()+adjustLayoutForCollapse oldPath = do+ layout <- getLayoutSt+ let oldLayout = layoutFromPath oldPath layout+ setLayoutSt $ adjustLayout (init oldPath) layout oldLayout++--+-- | Changes the layout for a move+--+adjustLayoutForGroupMove :: PaneMonad alpha => PanePath -> PanePath -> String -> alpha ()+adjustLayoutForGroupMove fromPath toPath group = do+ layout <- getLayout+ let layoutToMove = layoutFromPath fromPath layout+ let newLayout = removeGL fromPath layout+ setLayoutSt (addGL layoutToMove (toPath ++ [GroupP group]) newLayout)++--+-- | Changes the layout for a remove+--+adjustLayoutForGroupRemove :: PaneMonad alpha => PanePath -> String -> alpha ()+adjustLayoutForGroupRemove fromPath group = do+ layout <- getLayout+ setLayoutSt (removeGL fromPath layout)++--+-- | Remove group layout at a certain path+--+removeGL :: PanePath -> PaneLayout -> PaneLayout+removeGL [GroupP group] t@(TerminalP oldGroups _ _ _ _)+ | group `Map.member` oldGroups = t{paneGroups = group `Map.delete` oldGroups}+removeGL (GroupP group:r) old@(TerminalP {paneGroups = groups})+ | group `Map.member` groups = old{paneGroups = Map.adjust (removeGL r) group groups}+removeGL (SplitP TopP:r) (HorizontalP tp bp _) = HorizontalP (removeGL r tp) bp 0+removeGL (SplitP BottomP:r) (HorizontalP tp bp _) = HorizontalP tp (removeGL r bp) 0+removeGL (SplitP LeftP:r) (VerticalP lp rp _) = VerticalP (removeGL r lp) rp 0+removeGL (SplitP RightP:r) (VerticalP lp rp _) = VerticalP lp (removeGL r rp) 0+removeGL p l = error $"ViewFrame>>removeGL: inconsistent layout" ++ show p ++ " " ++ show l++--+-- | Add group layout at a certain path+--+addGL :: PaneLayout -> PanePath -> PaneLayout -> PaneLayout+addGL toAdd [GroupP group] t@(TerminalP oldGroups _ _ _ _) = t{paneGroups = Map.insert group toAdd oldGroups}+addGL toAdd (GroupP group:r) old@(TerminalP {paneGroups = groups})+ | group `Map.member` groups = old{paneGroups = Map.adjust (addGL toAdd r) group groups}+addGL toAdd (SplitP TopP:r) (HorizontalP tp bp _) = HorizontalP (addGL toAdd r tp) bp 0+addGL toAdd (SplitP BottomP:r) (HorizontalP tp bp _) = HorizontalP tp (addGL toAdd r bp) 0+addGL toAdd (SplitP LeftP:r) (VerticalP lp rp _) = VerticalP (addGL toAdd r lp) rp 0+addGL toAdd (SplitP RightP:r) (VerticalP lp rp _) = VerticalP lp (addGL toAdd r rp) 0+addGL _ p l = error $"ViewFrame>>addGL: inconsistent layout" ++ show p ++ " " ++ show l++--+-- | Changes the layout by replacing element at pane path (pp) with replace+--+adjustLayout :: PanePath -> PaneLayout -> PaneLayout -> PaneLayout+adjustLayout pp layout replace = adjust' pp layout+ where+ adjust' [] _ = replace+ adjust' (GroupP group:r) old@(TerminalP {paneGroups = groups})+ | group `Map.member` groups =+ old{paneGroups = Map.adjust (adjustPaneGroupLayout r) group groups}+ adjust' (SplitP TopP:r) (HorizontalP tp bp _) = HorizontalP (adjust' r tp) bp 0+ adjust' (SplitP BottomP:r) (HorizontalP tp bp _) = HorizontalP tp (adjust' r bp) 0+ adjust' (SplitP LeftP:r) (VerticalP lp rp _) = VerticalP (adjust' r lp) rp 0+ adjust' (SplitP RightP:r) (VerticalP lp rp _) = VerticalP lp (adjust' r rp) 0+ adjust' p l = error $"inconsistent layout (adjust) " ++ show p ++ " " ++ show l+ adjustPaneGroupLayout p group = adjust' p group++--+-- | Get the widget from a list of strings+--+widgetFromPath :: Widget -> [String] -> IO (Widget)+widgetFromPath w [] = return w+widgetFromPath w path = do+ children <- containerGetChildren (castToContainer w)+ chooseWidgetFromPath children path++chooseWidgetFromPath :: [Widget] -> [String] -> IO (Widget)+chooseWidgetFromPath _ [] = error $"Cant't find widget (empty path)"+chooseWidgetFromPath widgets (h:t) = do+ names <- mapM widgetGetName widgets+ let mbiInd = findIndex (== h) names+ case mbiInd of+ Nothing -> error $"Cant't find widget path " ++ show (h:t) ++ " found only " ++ show names+ Just ind -> widgetFromPath (widgets !! ind) t++widgetGet :: PaneMonad alpha => [String] -> (Widget -> b) -> alpha (b)+widgetGet strL cf = do+ windows <- getWindowsSt+ r <- liftIO $chooseWidgetFromPath (map castToWidget windows) strL+ return (cf r)++widgetGetRel :: Widget -> [String] -> (Widget -> b) -> IO (b)+widgetGetRel w sl cf = do+ r <- widgetFromPath w sl+ return (cf r)++getUIAction :: PaneMonad alpha => String -> (Action -> a) -> alpha (a)+getUIAction str f = do+ uiManager <- getUiManagerSt+ liftIO $ do+ findAction <- uiManagerGetAction uiManager str+ case findAction of+ Just act -> return (f act)+ Nothing -> error $"getUIAction can't find action " ++ str++getThis :: PaneMonad delta => (FrameState delta -> alpha) -> delta alpha+getThis sel = do+ st <- getFrameState+ return (sel st)+setThis :: PaneMonad delta => (FrameState delta -> alpha -> FrameState delta) -> alpha -> delta ()+setThis sel value = do+ st <- getFrameState+ setFrameState (sel st value)++getWindowsSt = getThis windows+setWindowsSt = setThis (\st value -> st{windows = value})+getUiManagerSt = getThis uiManager+getPanesSt = getThis panes+setPanesSt = setThis (\st value -> st{panes = value})+getPaneMapSt = getThis paneMap+setPaneMapSt = setThis (\st value -> st{paneMap = value})+getActivePaneSt = getThis activePane+setActivePaneSt = setThis (\st value -> st{activePane = value})+getLayoutSt = getThis layout+setLayoutSt = setThis (\st value -> st{layout = value})+getPanePathFromNB = getThis panePathFromNB+setPanePathFromNB = setThis (\st value -> st{panePathFromNB = value})+++getActivePane = getActivePaneSt+setActivePane = setActivePaneSt+getUiManager = getUiManagerSt+getWindows = getWindowsSt+getMainWindow = liftM head getWindows+getLayout = getLayoutSt
src/IDE/Completion.hs view
@@ -19,264 +19,271 @@ import Data.IORef import Control.Monad import Control.Monad.Trans (liftIO)-import Control.Concurrent import Graphics.UI.Gtk as Gtk import Graphics.UI.Gtk.SourceView import Graphics.UI.Gtk.Gdk.Events as Gtk import IDE.Core.State import IDE.Metainfo.Provider(getDescription,getCompletionOptions)+import Control.Monad.Reader.Class (ask) complete :: SourceView -> Bool -> IDEAction complete sourceView always = do currentState' <- readIDE currentState prefs' <- readIDE prefs- case currentState' of- IsCompleting window tv ls _ -> updateOptions window tv ls sourceView- IsRunning -> when (always || not (completeRestricted prefs'))- (initCompletion sourceView)- _ -> return ()-+ completion' <- readIDE completion+ case (currentState',completion') of+ (IsCompleting c, Just (CompletionWindow window tv st)) ->+ updateOptions window tv st sourceView c+ (IsRunning,_) -> when (always || not (completeRestricted prefs'))+ (initCompletion sourceView)+ _ -> return () cancel :: IDEAction cancel = do currentState' <- readIDE currentState- case currentState' of- IsCompleting window tv ls c -> cancelCompletion window tv ls c- _ -> return ()+ completion' <- readIDE completion+ case (currentState',completion') of+ (IsCompleting conn , Just (CompletionWindow window tv st)) ->+ cancelCompletion window tv st conn+ _ -> return () initCompletion :: SourceView -> IDEAction initCompletion sourceView = do- mainWindow <- readIDE window- prefs <- readIDE prefs- (window', tree', store', cids) <- reifyIDE (\ideR -> do- window <- windowNewPopup- --set window [ windowTypeHint := WindowTypeHintDialog ] --,- -- windowDecorated := False ]- --widgetSetSizeRequest window 700 300- windowSetTransientFor window mainWindow- paned <- hPanedNew- containerAdd window paned- scrolledWindow <- scrolledWindowNew Nothing Nothing- widgetSetSizeRequest scrolledWindow 300 300- containerAdd paned scrolledWindow- tree <- treeViewNew- containerAdd scrolledWindow tree- store <- listStoreNew []- treeViewSetModel tree store-- font <- case textviewFont prefs of- Just str -> do- fontDescriptionFromString str- Nothing -> do- f <- fontDescriptionNew- fontDescriptionSetFamily f "Monospace"- return f- widgetModifyFont tree (Just font)+ ideR <- ask+ completion' <- readIDE completion+ case completion' of+ Just (CompletionWindow window' tree' store') -> do+ cids <- liftIO $ addEventHandling sourceView tree' store' ideR+ modifyIDE_ (\ide -> ide{currentState = IsCompleting cids})+ updateOptions window' tree' store' sourceView cids+ Nothing -> do+ windows <- getWindows+ prefs <- readIDE prefs+ (window', tree', store', cids) <- reifyIDE (\ideR -> do+ window <- windowNewPopup+ set window [ windowTypeHint := WindowTypeHintTooltip,+ windowDecorated := False ]+ --widgetSetSizeRequest window 700 300+ windowSetTransientFor window (head windows)+ paned <- hPanedNew+ containerAdd window paned+ scrolledWindow <- scrolledWindowNew Nothing Nothing+ widgetSetSizeRequest scrolledWindow 300 300+ containerAdd paned scrolledWindow+ tree <- treeViewNew+ containerAdd scrolledWindow tree+ store <- listStoreNew []+ treeViewSetModel tree store - column <- treeViewColumnNew- set column [ treeViewColumnSizing := TreeViewColumnAutosize ]- treeViewAppendColumn tree column- renderer <- cellRendererTextNew- treeViewColumnPackStart column renderer True- cellLayoutSetAttributes column renderer store (\name -> [ cellText := name ])+ font <- case textviewFont prefs of+ Just str -> do+ fontDescriptionFromString str+ Nothing -> do+ f <- fontDescriptionNew+ fontDescriptionSetFamily f "Monospace"+ return f+ widgetModifyFont tree (Just font) - set tree [treeViewHeadersVisible := False]+ column <- treeViewColumnNew+ set column [ treeViewColumnSizing := TreeViewColumnAutosize ]+ treeViewAppendColumn tree column+ renderer <- cellRendererTextNew+ treeViewColumnPackStart column renderer True+ cellLayoutSetAttributes column renderer store (\name -> [ cellText := name ]) - descriptionView <- sourceViewNew- descriptionBuffer <- (get descriptionView textViewBuffer) >>= (return . castToSourceBuffer)- lm <- sourceLanguageManagerNew- mbLang <- sourceLanguageManagerGuessLanguage lm Nothing (Just "text/x-haskell")- case mbLang of- Nothing -> return ()- Just lang -> do sourceBufferSetLanguage descriptionBuffer lang+ set tree [treeViewHeadersVisible := False] - -- This call is here because in the past I have had problems where the- -- language object became invalid if the manager was garbage collected- sourceLanguageManagerGetLanguageIds lm+ descriptionView <- sourceViewNew+ descriptionBuffer <- (get descriptionView textViewBuffer) >>= (return . castToSourceBuffer)+ lm <- sourceLanguageManagerNew+ mbLang <- sourceLanguageManagerGuessLanguage lm Nothing (Just "text/x-haskell")+ case mbLang of+ Nothing -> return ()+ Just lang -> do sourceBufferSetLanguage descriptionBuffer lang - sourceBufferSetHighlightSyntax descriptionBuffer True- widgetModifyFont descriptionView (Just font)+ -- This call is here because in the past I have had problems where the+ -- language object became invalid if the manager was garbage collected+ sourceLanguageManagerGetLanguageIds lm - containerAdd paned descriptionView+ sourceBufferSetHighlightSyntax descriptionBuffer True+ widgetModifyFont descriptionView (Just font) - visible <- newIORef False- activeView <- newIORef Nothing+ containerAdd paned descriptionView - treeSelection <- treeViewGetSelection tree+ visible <- newIORef False+ activeView <- newIORef Nothing - treeSelection `onSelectionChanged` (do- treeSelectionSelectedForeach treeSelection (\treePath -> (do- rows <- treeSelectionGetSelectedRows treeSelection- case rows of- [treePath] -> withWord store treePath (\name -> do- description <- reflectIDE (getDescription name) ideR- textBufferSetText descriptionBuffer description- )- _ -> return ()- ))- )+ treeSelection <- treeViewGetSelection tree - tree `onRowActivated` (\treePath column -> (do- withWord store treePath (\name -> do- buffer <- textViewGetBuffer sourceView- (start, end) <- textBufferGetSelectionBounds buffer- isWordEnd <- textIterEndsWord end- if isWordEnd then (do- moveToWordStart start- wordStart <- textBufferGetText buffer start end True- if (isPrefixOf wordStart name) then (do- textBufferDelete buffer start end- textBufferInsert buffer start name- )- else return ()+ treeSelection `onSelectionChanged` (do+ treeSelectionSelectedForeach treeSelection (\treePath -> (do+ rows <- treeSelectionGetSelectedRows treeSelection+ case rows of+ [treePath] -> withWord store treePath (\name -> do+ description <- reflectIDE (getDescription name) ideR+ textBufferSetText descriptionBuffer description+ )+ _ -> return ()+ )) )- else return ()++ cids <- liftIO $ addEventHandling sourceView tree store ideR+ return (window, tree, store, cids) )- reflectIDE cancel ideR- ))+ modifyIDE_ (\ide -> ide{currentState = IsCompleting cids,+ completion = Just (CompletionWindow window' tree' store')})+ updateOptions window' tree' store' sourceView cids - cidPress <- sourceView `onKeyPress` (\event -> do- let Key { eventKeyName = name, eventModifier = modifier, eventKeyChar = char } = event- 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--- return True--- )- ("Tab", _, _) -> (do- visible <- get tree widgetVisible- if visible then (do- maybeRow <- getRow tree- case maybeRow of- Just row -> treeViewRowActivated tree [row] column- Nothing -> return ()- return True- )- else return False- )- ("Return", _, _) -> (do- visible <- get tree widgetVisible- if visible then (do- maybeRow <- getRow tree- case maybeRow of- Just row -> (do- treeViewRowActivated tree [row] column- return True- )- Nothing -> (do- reflectIDE cancel ideR- return False- )- )- else return False+addEventHandling :: SourceView -> TreeView -> ListStore String -> IDERef -> IO Connections+addEventHandling sourceView tree store ideR = do+ cidPress <- sourceView `onKeyPress` (\event -> do+ let Key { eventKeyName = name, eventModifier = modifier, eventKeyChar = char } = event+ Just model <- treeViewGetModel tree+ selection <- treeViewGetSelection tree+ count <- treeModelIterNChildren model Nothing+ Just column <- treeViewGetColumn tree 0+ case (name, modifier, char) of+ ("Tab", _, _) -> (do+ visible <- get tree widgetVisible+ if visible then (do+ maybeRow <- getRow tree+ case maybeRow of+ Just row -> treeViewRowActivated tree [row] column+ Nothing -> return ()+ return True )- ("Down", _, _) -> (do- visible <- get tree widgetVisible- if visible then (do- maybeRow <- getRow tree- let newRow = maybe 0 (\row -> row + 1) maybeRow- when (newRow < count) (do- treeSelectionSelectPath selection [newRow]- treeViewScrollToCell tree [newRow] column Nothing- -- Crazy hack to avoid the horizontal scroll- treeViewScrollToCell tree [newRow] column Nothing+ else return False+ )+ ("Return", _, _) -> (do+ visible <- get tree widgetVisible+ if visible then (do+ maybeRow <- getRow tree+ case maybeRow of+ Just row -> (do+ treeViewRowActivated tree [row] column+ return True )- return True- )- else return False- )- ("Up", _, _) -> (do- visible <- get tree widgetVisible- if visible then (do- maybeRow <- getRow tree- let newRow = maybe 0 (\row -> row - 1) maybeRow- when (newRow >= 0) (do- treeSelectionSelectPath selection [newRow]- treeViewScrollToCell tree [newRow] column Nothing- -- Crazy hack to avoid the horizontal scroll- treeViewScrollToCell tree [newRow] column Nothing+ Nothing -> (do+ reflectIDE cancel ideR+ return False )- return True- )- else return False )- (_, _, Just c) | ((isAlphaNum c) || (c == '.') || (c == '_')) -> (do- return False- )- ("BackSpace", _, _) -> (do- return False- )- (shift, _, _) | (shift == "Shift_L") || (shift == "Shift_R") -> (do- return False+ else return False+ )+ ("Down", _, _) -> (do+ visible <- get tree widgetVisible+ if visible then (do+ maybeRow <- getRow tree+ let newRow = maybe 0 (\row -> row + 1) maybeRow+ when (newRow < count) (do+ treeSelectionSelectPath selection [newRow]+ treeViewScrollToCell tree [newRow] column Nothing+ -- Crazy hack to avoid the horizontal scroll+ treeViewScrollToCell tree [newRow] column Nothing+ )+ return True )- _ -> (do- reflectIDE cancel ideR- return False+ else return False+ )+ ("Up", _, _) -> (do+ visible <- get tree widgetVisible+ if visible then (do+ maybeRow <- getRow tree+ let newRow = maybe 0 (\row -> row - 1) maybeRow+ when (newRow >= 0) (do+ treeSelectionSelectPath selection [newRow]+ treeViewScrollToCell tree [newRow] column Nothing+ -- Crazy hack to avoid the horizontal scroll+ treeViewScrollToCell tree [newRow] column Nothing+ )+ return True )- )+ else return False+ )+ (_, _, Just c) | ((isAlphaNum c) || (c == '.') || (c == '_')) -> (do+ return False+ )+ ("BackSpace", _, _) -> (do+ return False+ )+ (shift, _, _) | (shift == "Shift_L") || (shift == "Shift_R") -> (do+ return False+ )+ _ -> (do+ reflectIDE cancel ideR+ return False+ )+ ) - cidRelease <- sourceView `onKeyRelease` (\event -> do- let Key { eventKeyName = name, eventModifier = modifier, eventKeyChar = char } = event- case (name, modifier, char) of- ("BackSpace", _, _) -> (do- reflectIDE (complete sourceView False) ideR- return False+ cidRelease <- sourceView `onKeyRelease` (\event -> do+ let Key { eventKeyName = name, eventModifier = modifier, eventKeyChar = char } = event+ case (name, modifier, char) of+ ("BackSpace", _, _) -> (do+ reflectIDE (complete sourceView False) ideR+ return False+ )+ _ -> return False+ )+ cidSelected <- tree `onRowActivated` (\treePath column -> (do+ withWord store treePath (\name -> do+ buffer <- textViewGetBuffer sourceView+ (start, end) <- textBufferGetSelectionBounds buffer+ isWordEnd <- textIterEndsWord end+ if isWordEnd then (do+ moveToWordStart start+ wordStart <- textBufferGetText buffer start end True+ if (isPrefixOf wordStart name) then (do+ textBufferDelete buffer start end+ textBufferInsert buffer start name )- _ -> return False+ else return ()+ )+ else return () )-- return (window, tree, store, [cidPress, cidRelease])- )-- modifyIDE_ (\ide -> return (ide{currentState = IsCompleting window' tree' store' (map ConnectC cids)}))- updateOptions window' tree' store' sourceView+ reflectIDE cancel ideR))+ return [ConnectC cidPress,ConnectC cidRelease, ConnectC cidSelected] - where- withWord store treePath f = (do- case treePath of- [row] -> (do- value <- listStoreGetValue store row- f value- )- _ -> return ()- )+withWord store treePath f = (do+ case treePath of+ [row] -> (do+ value <- listStoreGetValue store row+ f value+ )+ _ -> return ()+ ) cancelCompletion :: TreeViewClass alpha => Window -> alpha -> ListStore String -> Connections -> IDEAction cancelCompletion window tree store connections = do liftIO (do+ listStoreClear (store :: ListStore String) signalDisconnectAll connections widgetHideAll window- widgetDestroy window )- modifyIDE_ (\ide -> return (ide{currentState = IsRunning}))+ modifyIDE_ (\ide -> ide{currentState = IsRunning}) -updateOptions :: TreeViewClass alpha => Window -> alpha -> ListStore String -> SourceView -> IDEAction-updateOptions window tree store sourceView =+updateOptions :: TreeViewClass alpha => Window -> alpha -> ListStore String -> SourceView -> Connections -> IDEAction+updateOptions window tree store sourceView connections = reifyIDE (\ideR -> do buffer <- textViewGetBuffer sourceView listStoreClear (store :: ListStore String) (start, end) <- textBufferGetSelectionBounds buffer- isWordEnd <- textIterEndsWord end- when isWordEnd (do- moveToWordStart start- wordStart <- textBufferGetText buffer start end True- forkIO (do- options <- reflectIDE (getCompletionOptions wordStart) ideR- postGUIAsync $ processResults ideR window tree store sourceView wordStart options- return ()- )- return ()- )- )+ moveToWordStart start+ equal <- textIterEqual start end+ if equal+ then reflectIDE (cancelCompletion window tree store connections) ideR+ else do+ wordStart <- textBufferGetText buffer start end True+ postGUIAsync $ do+ options <- reflectIDE (getCompletionOptions wordStart) ideR+ processResults ideR window tree store sourceView wordStart options+ return ()+ return ()) moveToWordStart iter = do textIterBackwardWordStart iter isStart <- textIterIsStart iter- when (not isStart) (do+ when (not isStart) $ do prev <- textIterCopy iter textIterBackwardChar prev maybeChar <- textIterGetChar prev@@ -286,30 +293,27 @@ moveToWordStart iter ) _ -> return ()- ) processResults ideR window tree store sourceView wordStart options = do- buffer <- textViewGetBuffer sourceView- (start, end) <- textBufferGetSelectionBounds buffer- isWordEnd <- textIterEndsWord end- when isWordEnd (do- moveToWordStart start- newWordStart <- textBufferGetText buffer start end True- when (isPrefixOf wordStart newWordStart) (do- 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) $ treeViewSetCursor tree [0] Nothing- case options of- [] -> reflectIDE cancel ideR- -- [(wordStart,_)] -> (cancel completion) getRow- _ -> widgetShowAll window- )- )+ case options of+ [] -> reflectIDE cancel ideR+ _ -> do+ buffer <- textViewGetBuffer sourceView+ (start, end) <- textBufferGetSelectionBounds buffer+ isWordEnd <- textIterEndsWord end+ when isWordEnd (do+ moveToWordStart start+ newWordStart <- textBufferGetText buffer start end True+ when (isPrefixOf wordStart newWordStart) (do+ 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) $ treeViewSetCursor tree [0] Nothing+ widgetShowAll window)) getRow tree = do Just model <- treeViewGetModel tree
src/IDE/Core/State.hs view
@@ -20,6 +20,18 @@ IDEObject , IDEEditor , IDE(..)+, window+, errorRefs+, breakpointRefs+, contextRefs+, currentError+, currentBreak+, currentContext+, setCurrentError+, setCurrentBreak+, setCurrentContext+, isInterpreting+ , IDEState(..) , isStartingOrClosing , IDERef@@ -27,6 +39,8 @@ , IDEAction , IDEEvent(..) +, triggerEventIDE+ -- * Convenience methods for accesing the IDE State , readIDE , modifyIDE@@ -37,7 +51,11 @@ , reifyIDE , reflectIDE , catchIDE+, postSyncIDE+, postAsyncIDE +, newPane+ , ideMessage , logMessage , sysMessage@@ -64,6 +82,8 @@ , setBackgroundBuildToggled , getBackgroundLinkToggled , setBackgroundLinkToggled+, getDebugToggled+, setDebugToggled , getRecentFiles , getRecentPackages@@ -95,11 +115,14 @@ import IDE.Core.Types import Graphics.UI.Frame.Panes-import Graphics.UI.Frame.ViewFrame+import Graphics.UI.Frame.ViewFrame hiding (notebookInsertOrdered)+import qualified Graphics.UI.Frame.ViewFrame as VF (notebookInsertOrdered) import IDE.Exception import Control.Event import System.IO import System.Process (ProcessHandle(..))+import IDE.Tool (ToolState(..))+import Data.Maybe (isJust) -- this should not be repeated here, why is it necessary? instance MonadIO Ghc where@@ -107,14 +130,12 @@ ideMessage :: MessageLevel -> String -> IDEAction ideMessage level str = do- st <- ask- triggerEvent st (LogMessage (str ++ "\n") LogTag)+ triggerEventIDE (LogMessage (str ++ "\n") LogTag) liftIO $ sysMessage level str logMessage :: String -> LogTag -> IDEAction logMessage str tag = do- st <- ask- triggerEvent st (LogMessage (str ++ "\n") tag)+ triggerEventIDE (LogMessage (str ++ "\n") tag) return () sysMessage :: MonadIO m => MessageLevel -> String -> m ()@@ -128,7 +149,6 @@ class IDEObject alpha class IDEObject o => IDEEditor o - -- --------------------------------------------------------------------- -- IDE State --@@ -137,21 +157,17 @@ -- | The IDE state -- data IDE = IDE {- window :: Window -- ^ the gtk window-, uiManager :: UIManager -- ^ the gtk uiManager-, panes :: Map PaneName (IDEPane IDEM) -- ^ a map with all panes (subwindows)-, activePane :: Maybe (PaneName,Connections)+ frameState :: FrameState IDEM -- ^ state of the windows framework , recentPanes :: [PaneName]-, paneMap :: Map PaneName (PanePath, Connections)- -- ^ a map from the pane name to its gui path and signal connections-, layout :: PaneLayout -- ^ a description of the general gui layout , specialKeys :: SpecialKeyTable IDERef -- ^ a structure for emacs like keystrokes , specialKey :: SpecialKeyCons IDERef -- ^ the first of a double keystroke , candy :: CandyTable -- ^ table for source candy , prefs :: Prefs -- ^ configuration preferences , activePack :: Maybe IDEPackage-, errors :: [ErrorSpec]-, currentErr :: Maybe Int+, projFilesCache :: Map FilePath Bool -- ^ caches property that a buffer belongs to a project+, allLogRefs :: [LogRef]+, currentEBC :: (Maybe LogRef, Maybe LogRef, Maybe LogRef)+, currentHist :: Int , accessibleInfo :: (Maybe (PackageScope)) -- ^ the world scope , currentInfo :: (Maybe (PackageScope,PackageScope)) -- ^ the first is for the current package,@@ -164,21 +180,54 @@ , toolbar :: (Bool,Maybe Toolbar) , recentFiles :: [FilePath] , recentPackages :: [FilePath]-, buildProcess :: Maybe ProcessHandle+, runningTool :: Maybe ProcessHandle+, ghciState :: Maybe ToolState+, completion :: Maybe CompletionWindow } --deriving Show +-- Main window is just the first one in the list+window = head . windows+++errorRefs :: IDE -> [LogRef]+errorRefs = (filter ((\t -> t == ErrorRef || t == WarningRef) . logRefType)) . allLogRefs++breakpointRefs :: IDE -> [LogRef]+breakpointRefs = (filter ((== BreakpointRef) . logRefType)) . allLogRefs++contextRefs :: IDE -> [LogRef]+contextRefs = (filter ((== ContextRef) . logRefType)) . allLogRefs++currentError = (\(e,_,_)-> e) . currentEBC+currentBreak = (\(_,b,_)-> b) . currentEBC+currentContext = (\(_,_,c)-> c) . currentEBC++setCurrentError e = do+ modifyIDE_ (\ide -> ide{currentEBC = (e, currentBreak ide, currentContext ide)})+ triggerEventIDE (CurrentErrorChanged e) >> return ()+setCurrentBreak b = do+ modifyIDE_ (\ide -> ide{currentEBC = (currentError ide, b, currentContext ide)})+ triggerEventIDE (CurrentBreakChanged b) >> return ()+setCurrentContext c = modifyIDE_ (\ide -> ide{currentEBC = (currentError ide, currentBreak ide, c)})++ data IDEState = IsStartingUp | IsShuttingDown | IsRunning | IsFlipping TreeView- | IsCompleting Window TreeView (ListStore String) Connections+ | IsCompleting Connections isStartingOrClosing :: IDEState -> Bool isStartingOrClosing IsStartingUp = True isStartingOrClosing IsShuttingDown = True isStartingOrClosing _ = False +isInterpreting :: IDEM Bool+isInterpreting = do+ readIDE ghciState >>= \mb -> return (isJust mb)++ data IDEEvent = CurrentInfo | ActivePack@@ -192,7 +241,13 @@ | LoadSession FilePath | SaveSession FilePath | UpdateRecent-+ | VariablesChanged+ | ErrorChanged+ | CurrentErrorChanged (Maybe LogRef)+ | BreakpointChanged+ | CurrentBreakChanged (Maybe LogRef)+ | TraceChanged+ | GetTextPopup (Maybe (IDERef -> Menu -> IO ())) -- -- | A mutable reference to the IDE state --@@ -211,10 +266,15 @@ getSelector (LoadSession _) = "LoadSession" getSelector (SaveSession _) = "SaveSession" getSelector UpdateRecent = "UpdateRecent"-+ getSelector VariablesChanged = "VariablesChanged"+ getSelector ErrorChanged = "ErrorChanged"+ getSelector (CurrentErrorChanged _) = "CurrentErrorChanged"+ getSelector BreakpointChanged = "BreakpointChanged"+ getSelector (CurrentBreakChanged _) = "CurrentBreakChanged"+ getSelector TraceChanged = "TraceChanged"+ getSelector (GetTextPopup _) = "GetTextPopup" instance EventSource IDERef IDEEvent IDEM String where- canTriggerEvent o "CurrentInfo" = True canTriggerEvent o "ActivePack" = True canTriggerEvent o "LogMessage" = True@@ -227,6 +287,13 @@ canTriggerEvent o "LoadSession" = True canTriggerEvent o "SaveSession" = True canTriggerEvent o "UpdateRecent" = True+ canTriggerEvent o "VariablesChanged" = True+ canTriggerEvent o "ErrorChanged" = True+ canTriggerEvent o "CurrentErrorChanged" = True+ canTriggerEvent o "BreakpointChanged" = True+ canTriggerEvent o "CurrentBreakChanged" = True+ canTriggerEvent o "TraceChanged" = True+ canTriggerEvent o "GetTextPopup" = True canTriggerEvent _ _ = False getHandlers ideRef = do@@ -242,6 +309,8 @@ instance EventSelector String +triggerEventIDE :: IDEEvent -> IDEM IDEEvent+triggerEventIDE e = ask >>= \ideR -> triggerEvent ideR e -- -- | A reader monad for a mutable reference to the IDE state@@ -251,13 +320,34 @@ reifyIDE :: (IDERef -> IO a) -> IDEM a reifyIDE = ReaderT - reflectIDE :: IDEM a -> IDERef -> IO a reflectIDE c ideR = runReaderT c ideR catchIDE :: Exception e => IDEM a -> (e -> IO a) -> IDEM a catchIDE block handler = reifyIDE (\ideR -> catch (reflectIDE block ideR) handler) +postSyncIDE :: IDEM a -> IDEM a+postSyncIDE f = reifyIDE (\ideR -> postGUISync (reflectIDE f ideR))++postAsyncIDE :: IDEM () -> IDEM ()+postAsyncIDE f = reifyIDE (\ideR -> postGUIAsync (reflectIDE f ideR))++newPane :: RecoverablePane alpha beta IDEM =>+ PanePath ->+ Notebook ->+ (PanePath -> Notebook -> Window -> IDERef -> IO (alpha,Connections)) ->+ IDEM alpha+newPane panePath notebook builder = do+ windows <- getWindows+ (buf,cids) <- reifyIDE (\ideR -> builder panePath notebook (head windows) ideR)+ VF.notebookInsertOrdered notebook (getTopWidget buf) (paneName buf) Nothing+ addPaneAdmin buf cids panePath+ liftIO $ do+ widgetShowAll (getTopWidget buf)+ widgetGrabFocus (getTopWidget buf)+ bringPaneToFront buf+ return buf+ -- -- | A shorthand for a reader monad for a mutable reference to the IDE state -- which does not return a value@@ -265,19 +355,16 @@ type IDEAction = IDEM () instance PaneMonad IDEM where- getWindowSt = readIDE window- getUIManagerSt = readIDE uiManager- getPanesSt = readIDE panes- getPaneMapSt = readIDE paneMap- getActivePaneSt = readIDE activePane- getLayoutSt = readIDE layout- setPanesSt v = modifyIDE_ (\ide -> return ide{panes = v})- setPaneMapSt v = modifyIDE_ (\ide -> return ide{paneMap = v})- setActivePaneSt v = modifyIDE_ (\ide -> return ide{activePane = v})- setLayoutSt v = modifyIDE_ (\ide -> return ide{layout = v})-+ getFrameState = readIDE frameState+ setFrameState v = modifyIDE_ (\ide -> ide{frameState = v}) runInIO f = reifyIDE (\ideRef -> return (\v -> reflectIDE (f v) ideRef))-+ panePathForGroup id = do+ prefs <- readIDE prefs+ case id `lookup` (categoryForPane prefs) of+ Just group -> case group `lookup` (pathForCategory prefs) of+ Nothing -> return (defaultPath prefs)+ Just p -> return p+ Nothing -> return (defaultPath prefs) -- ---------------------------------------------------------------------@@ -291,19 +378,16 @@ liftIO $ liftM f (readIORef e) -- | Modify the contents, using an IO action.-modifyIDE_ :: (IDE -> IO IDE) -> IDEM ()-modifyIDE_ f = do+modifyIDE_ :: (IDE -> IDE) -> IDEM ()+modifyIDE_ f = let f' a = (f a,()) in do e <- ask- e' <- liftIO $ (f =<< readIORef e)- liftIO $ writeIORef e e'+ liftIO (atomicModifyIORef e f') -- | Variation on modifyIDE_ that lets you return a value-modifyIDE :: (IDE -> IO (IDE,beta)) -> IDEM beta+modifyIDE :: (IDE -> (IDE,beta)) -> IDEM beta modifyIDE f = do e <- ask- (e',result) <- liftIO (f =<< readIORef e)- liftIO $ writeIORef e e'- return result+ liftIO (atomicModifyIORef e f) withIDE :: (IDE -> IO alpha) -> IDEM alpha withIDE f = do@@ -320,10 +404,10 @@ withoutRecordingDo act = do (b,l,n) <- readIDE guiHistory if not b then do- modifyIDE_ (\ide -> return ide{guiHistory = (True,l,n)})+ modifyIDE_ (\ide -> ide{guiHistory = (True,l,n)}) act (b,l,n) <- readIDE guiHistory- modifyIDE_ (\ide -> return ide{guiHistory = (False,l,n)})+ modifyIDE_ (\ide -> ide{guiHistory = (False,l,n)}) else act -- ---------------------------------------------------------------------@@ -334,7 +418,7 @@ activatePane :: Pane alpha IDEM => alpha -> Connections -> IDEAction activatePane pane conn = do- mbAP <- getActivePaneSt+ mbAP <- getActivePane case mbAP of Just (pn,_) | pn == paneName pane -> return () _ -> do@@ -343,32 +427,30 @@ liftIO $ statusbarPop sb 1 liftIO $ statusbarPush sb 1 (paneName pane) liftIO $ bringPaneToFront pane- setActivePaneSt (Just (paneName pane,conn))+ setActivePane (Just (paneName pane,conn)) trigger (Just (paneName pane)) (case mbAP of Nothing -> Nothing Just (pn,_) -> Just pn)- modifyIDE_ (\ide -> return ide{recentPanes =+ modifyIDE_ (\ide -> ide{recentPanes = paneName pane : filter (/= paneName pane) (recentPanes ide)}) return () trigger :: Maybe String -> Maybe String -> IDEAction trigger s1 s2 = do- st <- ask- triggerEvent st (RecordHistory ((PaneSelected s1), PaneSelected s2))- triggerEvent st (Sensitivity [(SensitivityEditor, False)])+ triggerEventIDE (RecordHistory ((PaneSelected s1), PaneSelected s2))+ triggerEventIDE (Sensitivity [(SensitivityEditor, False)]) return () deactivatePane :: IDEAction deactivatePane = do- ideR <- ask- mbAP <- getActivePaneSt+ mbAP <- getActivePane case mbAP of Nothing -> return () Just (pn, _) -> do deactivatePaneWithout- triggerEvent ideR (RecordHistory (PaneSelected Nothing,+ triggerEventIDE (RecordHistory (PaneSelected Nothing, PaneSelected (Just pn)))- triggerEvent ideR (Sensitivity [(SensitivityEditor, False)])+ triggerEventIDE (Sensitivity [(SensitivityEditor, False)]) return () deactivatePaneWithout :: IDEAction@@ -376,49 +458,50 @@ sb <- getSBActivePane liftIO $ statusbarPop sb 1 liftIO $ statusbarPush sb 1 ""- mbAP <- getActivePaneSt+ mbAP <- getActivePane case mbAP of Just (_,signals) -> liftIO $do signalDisconnectAll signals Nothing -> return ()- setActivePaneSt Nothing+ setActivePane Nothing deactivatePaneIfActive :: Pane alpha IDEM => alpha -> IDEAction deactivatePaneIfActive pane = do- mbActive <- getActivePaneSt+ mbActive <- getActivePane case mbActive of Nothing -> return () Just (n,_) -> if n == paneName pane then deactivatePane else return () -closePane :: Pane alpha IDEM => alpha -> IDEAction+closePane :: Pane alpha IDEM => alpha -> IDEM Bool closePane pane = do (panePath,_) <- guiPropertiesFromName (paneName pane) nb <- getNotebook panePath mbI <- liftIO $notebookPageNum nb (getTopWidget pane) case mbI of Nothing -> liftIO $ do- sysMessage Normal "notebook page not found: unexpected"- return ()+ throwIDE ("notebook page not found: unexpected " ++ paneName pane ++ " " ++ show panePath)+ return False Just i -> do deactivatePaneIfActive pane liftIO $ do notebookRemovePage nb i widgetDestroy (getTopWidget pane) removePaneAdmin pane- modifyIDE_ (\ide -> return ide{recentPanes = filter (/= paneName pane) (recentPanes ide)})+ modifyIDE_ (\ide -> ide{recentPanes = filter (/= paneName pane) (recentPanes ide)})+ return True -- get widget elements (menu & toolbar) -getCandyState :: PaneMonad alpha => alpha (Bool)+getCandyState :: PaneMonad alpha => alpha Bool getCandyState = do- ui <- getUIAction "ui/menubar/_Edit/Source Candy" castToToggleAction+ ui <- getUIAction "ui/menubar/_Configuration/Source Candy" castToToggleAction liftIO $toggleActionGetActive ui setCandyState :: PaneMonad alpha => Bool -> alpha () setCandyState b = do- ui <- getUIAction "ui/menubar/_Edit/Source Candy" castToToggleAction+ ui <- getUIAction "ui/menubar/_Configuration/Source Candy" castToToggleAction liftIO $toggleActionSetActive ui b getForgetSession :: PaneMonad alpha => alpha (Bool)@@ -428,7 +511,7 @@ getMenuItem :: String -> IDEM MenuItem getMenuItem path = do- uiManager' <- readIDE uiManager+ uiManager' <- getUiManager mbWidget <- liftIO $ uiManagerGetWidget uiManager' path case mbWidget of Nothing -> throwIDE ("State.hs>>getMenuItem: Can't find ui path " ++ path)@@ -454,6 +537,16 @@ ui <- getUIAction "ui/toolbar/BuildToolItems/BackgroundLink" castToToggleAction liftIO $ toggleActionSetActive ui b +getDebugToggled :: PaneMonad alpha => alpha (Bool)+getDebugToggled = do+ ui <- getUIAction "ui/toolbar/BuildToolItems/Debug" castToToggleAction+ liftIO $ toggleActionGetActive ui++setDebugToggled :: PaneMonad alpha => Bool -> alpha ()+setDebugToggled b = do+ ui <- getUIAction "ui/toolbar/BuildToolItems/Debug" castToToggleAction+ liftIO $ toggleActionSetActive ui b+ getRecentFiles , getRecentPackages :: IDEM MenuItem getRecentFiles = getMenuItem "ui/menubar/_File/_Recent Files" getRecentPackages = getMenuItem "ui/menubar/_Package/_Recent Packages"@@ -461,25 +554,24 @@ -- (toolbar) getSBSpecialKeys :: PaneMonad alpha => alpha Statusbar-getSBSpecialKeys = widgetGet ["topBox","statusBox","statusBarSpecialKeys"] castToStatusbar+getSBSpecialKeys = widgetGet ["Leksah Main Window", "topBox","statusBox","statusBarSpecialKeys"] castToStatusbar getSBActivePane :: PaneMonad alpha => alpha Statusbar-getSBActivePane = widgetGet ["topBox","statusBox","statusBarActivePane"] castToStatusbar+getSBActivePane = widgetGet ["Leksah Main Window", "topBox","statusBox","statusBarActivePane"] castToStatusbar getSBActivePackage :: PaneMonad alpha => alpha Statusbar-getSBActivePackage = widgetGet ["topBox","statusBox","statusBarActiveProject"] castToStatusbar+getSBActivePackage = widgetGet ["Leksah Main Window", "topBox","statusBox","statusBarActiveProject"] castToStatusbar getSBErrors :: PaneMonad alpha => alpha Statusbar-getSBErrors = widgetGet ["topBox","statusBox","statusBarErrors"] castToStatusbar+getSBErrors = widgetGet ["Leksah Main Window", "topBox","statusBox","statusBarErrors"] castToStatusbar getStatusbarIO :: PaneMonad alpha => alpha Statusbar-getStatusbarIO = widgetGet ["topBox","statusBox","statusBarInsertOverwrite"] castToStatusbar+getStatusbarIO = widgetGet ["Leksah Main Window", "topBox","statusBox","statusBarInsertOverwrite"] castToStatusbar getStatusbarLC :: PaneMonad alpha => alpha Statusbar-getStatusbarLC = widgetGet ["topBox","statusBox","statusBarLineColumn"] castToStatusbar+getStatusbarLC = widgetGet ["Leksah Main Window", "topBox","statusBox","statusBarLineColumn"] castToStatusbar controlIsPressed :: G.Event -> Bool controlIsPressed (G.Button _ _ _ _ _ mods _ _ _) | Control `elem` mods = True controlIsPressed _ = False-
src/IDE/Core/Types.hs view
@@ -29,7 +29,11 @@ , Prefs(..) -, ErrorSpec(..)+, LogRefType(..)+, LogRef(..)+, filePath+, isError+, isBreakpoint , PackageDescr(..) , ModuleDescr(..)@@ -75,13 +79,15 @@ , SensitivityMask(..) , SearchMode(..)++, CompletionWindow(..) ) where import Control.Monad.Reader import Graphics.UI.Gtk hiding (get) import Graphics.UI.Gtk.Gdk.Events(Modifier(..)) import qualified Data.Map as Map-import Data.Set(Set)+--import Data.Set(Set) import qualified Data.Set as Set import Default@@ -96,6 +102,10 @@ import Data.ByteString.Char8 (ByteString) import MyMissing import Data.Typeable (Typeable(..))+import SrcLoc (SrcSpan(..))+import FastString (unpackFS)+import Outputable (ppr, showSDoc)+import Data.Set (Set(..)) -- --------------------------------------------------------------------- -- IDEPackages@@ -105,6 +115,9 @@ packageId :: PackageIdentifier , cabalFile :: FilePath , depends :: [Dependency]+, modules :: Set ModuleName+, extraSrcs :: Set FilePath+, srcDirs :: [FilePath] , configFlags :: [String] , buildFlags :: [String] , haddockFlags :: [String]@@ -153,9 +166,9 @@ , logviewFont :: Maybe String , defaultSize :: (Int,Int) , browser :: String- , sourcePanePath :: StandardPath- , logPanePath :: StandardPath- , modulesPanePath :: StandardPath+ , pathForCategory :: [(String, PanePath)]+ , defaultPath :: PanePath+ , categoryForPane :: [(String, String)] , sourceDirectories :: [FilePath] , packageBlacklist :: [Dependency] , collectAfterBuild :: Bool@@ -167,6 +180,10 @@ , saveAllBeforeBuild :: Bool , backgroundBuild :: Bool , backgroundLink :: Bool+ , printEvldWithShow :: Bool+ , breakOnException :: Bool+ , breakOnError :: Bool+ , printBindResult :: Bool } deriving(Eq,Show) data SearchHint = Forward | Backward | Insert | Delete | Initial@@ -178,15 +195,30 @@ -- -- | Other types ---data ErrorSpec = ErrorSpec {- filePath :: FilePath-, line :: Int-, column :: Int-, errDescription :: String+data LogRefType = WarningRef | ErrorRef | BreakpointRef | ContextRef deriving (Eq, Show)++data LogRef = LogRef {+ logRefSrcSpan :: SrcSpan+, refDescription :: String , logLines :: (Int,Int)-, isError :: Bool-} deriving Show+, logRefType :: LogRefType+} deriving (Eq) +instance Show LogRef where+ show lr = refDescription lr ++ showSDoc (ppr (logRefSrcSpan lr))++filePath :: LogRef -> FilePath+filePath = unpackFS . srcSpanFile. logRefSrcSpan++isError :: LogRef -> Bool+isError = (== ErrorRef) . logRefType++isBreakpoint :: LogRef -> Bool+isBreakpoint = (== BreakpointRef) . logRefType++isContext :: LogRef -> Bool+isContext = (== ContextRef) . logRefType+ -- --------------------------------------------------------------------- -- | Information about the world, extraced from .hi and maybe source files --@@ -399,7 +431,7 @@ type SpecialKeyCons alpha = Maybe ((Map (KeyVal,[Modifier]) (ActionDescr alpha)),String) -data LogTag = LogTag | ErrorTag | FrameTag+data LogTag = LogTag | ErrorTag | FrameTag | InputTag | InfoTag -- | the first one is the new and the second the old state type GUIHistory = (GUIHistory', GUIHistory')@@ -423,12 +455,20 @@ | SensitivityProjectActive | SensitivityError | SensitivityEditor+ | SensitivityInterpreting deriving (Eq, Ord, Show) data SearchMode = Exact {caseSense :: Bool} | Prefix {caseSense :: Bool} | Regex {caseSense :: Bool} deriving (Eq,Ord,Read,Show)++data CompletionWindow = CompletionWindow {+ cwWindow :: Window,+ cwTreeView :: TreeView,+ cwListStore :: ListStore String}++
+ src/IDE/Debug.hs view
@@ -0,0 +1,443 @@+{-# LANGUAGE CPP, ForeignFunctionInterface #-}+{-# OPTIONS_GHC -XScopedTypeVariables #-}+-----------------------------------------------------------------------------+--+-- Module : IDE.Debug+-- Copyright : (c) Hamish Mackenzie, Juergen Nicklisch-Franken+-- License : GNU-GPL+--+-- Maintainer : <maintainer at leksah.org>+-- Stability : provisional+-- Portability : portable+--+--+-- | The debug methods of ide.+--+---------------------------------------------------------------------------------+++module IDE.Debug (+ executeDebugCommand+, debugCommand+, debugCommand'+, debugQuit+, debugExecuteSelection+, debugExecuteAndShowSelection++, debugSetBreakpoint+, debugDeleteAllBreakpoints+, debugDeleteBreakpoint++, debugContinue+, debugAbandon+, debugStop++, debugStep+, debugStepExpression+, debugStepExpr+, debugStepLocal+, debugStepModule++, debugTrace+, debugTraceExpression+, debugTraceExpr+, debugHistory+, debugBack+, debugForward++, debugForce+, debugPrint+, debugSimplePrint++, debugShowBindings+, debugShowBreakpoints+, debugShowContext+, debugShowModules+, debugShowPackages+, debugShowLanguages++, debugInformation+, debugKind+, debugType++, interactiveFlags+, debugSetPrintEvldWithShow+, debugSetBreakOnException+, debugSetBreakOnError+, debugSetPrintBindResult+) where++#if defined(mingw32_HOST_OS) || defined(__MINGW32__)+-- import System.Process (getProcessExitCode, ProcessHandle(..))+-- import Data.Maybe (isNothing)+import GHC.ConsoleHandler (Handler(..), installHandler)+import System.Win32+ (-- th32SnapEnumProcesses,+ DWORD(..),+ cTRL_BREAK_EVENT,+ generateConsoleCtrlEvent)+ -- tH32CS_SNAPPROCESS,+ -- withTh32Snap)+import System.Process.Internals+ (withProcessHandle, ProcessHandle__(..))+import Control.Concurrent.MVar (tryTakeMVar)+#else+import System.Posix+ (sigINT,+ installHandler,+ signalProcessGroup,+ getProcessGroupID)+import System.Posix.Signals (Handler(..))+#endif++import Graphics.UI.Gtk+import Control.Monad.Reader+import IDE.Core.State+import IDE.Tool+import IDE.LogRef+import Control.Exception (SomeException(..))+import IDE.Pane.SourceBuffer+ (selectedLocation,+ selectedModuleName,+ selectedText,+ insertTextAfterSelection)+import IDE.Pane.Log (appendLog)+import Data.List (isSuffixOf)+import IDE.Metainfo.Provider (getActivePackageDescr)+import Distribution.Text (display)++#if defined(mingw32_HOST_OS) || defined(__MINGW32__)+foreign import stdcall unsafe "winbase.h GetCurrentProcessId"+ c_GetCurrentProcessId :: IO DWORD++foreign import stdcall unsafe "winbase.h GetProcessId"+ c_GetProcessId :: DWORD -> IO DWORD+#endif++executeDebugCommand :: String -> ([ToolOutput] -> IDEAction) -> IDEAction+executeDebugCommand command handler = do+ maybeGhci <- readIDE ghciState+ case maybeGhci of+ Just ghci -> do+ sb <- getSBErrors+ reifyIDE $ \ideR -> do+ statusbarPop sb 1+ statusbarPush sb 1 $ (if '\n' `elem` command then (head $ lines command) ++ " ..." else command)+ executeGhciCommand ghci command $ \output ->+ reflectIDE (do+ handler output+ liftIO $ statusbarPush sb 1 ""+ return ()+ ) ideR+ _ -> sysMessage Normal "Debugger not running"++debugCommand :: String -> ([ToolOutput] -> IDEAction) -> IDEAction+debugCommand command handler = debugCommand' command+ (\to -> do+ handler to+ triggerEventIDE VariablesChanged+ return ())++debugCommand' :: String -> ([ToolOutput] -> IDEAction) -> IDEAction+debugCommand' command handler = do+ ideR <- ask+ catchIDE (executeDebugCommand command handler)+ (\(e :: SomeException) -> putStrLn (show e))++debugQuit :: IDEAction+debugQuit = debugCommand ":quit" logOutput++debugExecuteSelection :: IDEAction+debugExecuteSelection = do+ maybeText <- selectedText+ case maybeText of+ Just text -> do+ debugSetLiberalScope+ debugCommand text logOutput+ Nothing -> ideMessage Normal "Please select some text in the editor to execute"++debugExecuteAndShowSelection :: IDEAction+debugExecuteAndShowSelection = do+ maybeText <- selectedText+ case maybeText of+ Just text -> do+ debugSetLiberalScope+ debugCommand text (\to -> do+ insertTextAfterSelection $ " " ++ buildOutputString to+ logOutput to)+ Nothing -> ideMessage Normal "Please select some text in the editor to execute"+ where+ buildOutputString :: [ToolOutput] -> String+ buildOutputString (ToolOutput str:[]) = str+ buildOutputString (ToolOutput str:r) = str ++ "\n" ++ (buildOutputString r)+ buildOutputString (_:r) = buildOutputString r+ buildOutputString [] = ""++debugSetLiberalScope :: IDEAction+debugSetLiberalScope = do+ maybeModuleName <- selectedModuleName+ case maybeModuleName of+ Just moduleName -> do+ debugCommand (":module *" ++ moduleName) (\ _ -> return ())+ Nothing -> do+ mbPackage <- getActivePackageDescr+ case mbPackage of+ Nothing -> return ()+ Just p -> let packageNames = map (display . modu . moduleIdMD) (exposedModulesPD p)+ in debugCommand' (foldl (\a b -> a ++ " *" ++ b) ":module + " packageNames)+ (\ _ -> return ())++debugAbandon :: IDEAction+debugAbandon = debugCommand ":abandon" logOutput++debugBack :: IDEAction+debugBack = do+ currentHist' <- readIDE currentHist+ modifyIDE_ (\ide -> ide{currentHist = min (currentHist' - 1) 0})+ debugCommand ":back" logOutputForHistoricContext++debugForward :: IDEAction+debugForward = do+ currentHist' <- readIDE currentHist+ modifyIDE_ (\ide -> ide{currentHist = currentHist' + 1})+ debugCommand ":forward" logOutputForHistoricContext+++debugStop :: IDEAction+#if defined(mingw32_HOST_OS) || defined(__MINGW32__)+debugStop = do+ maybeGhci <- readIDE ghciState+ case maybeGhci of+ Just ghci -> do+ liftIO $ do+ maybeProcess <- tryTakeMVar (toolProcess ghci)+ processGroupId <- case maybeProcess of+ Just h -> do+ withProcessHandle h (\h2 -> do+ case h2 of+ OpenHandle oh -> do+ pid <- c_GetProcessId oh+ return (h2, pid)+ _ -> return (h2, 0))+ _ -> return 0+ old <- installHandler Ignore+ putStrLn $ show processGroupId+ generateConsoleCtrlEvent cTRL_BREAK_EVENT processGroupId+ installHandler old+ return ()+ Nothing -> return ()+#else+debugStop = do+ maybeGhci <- readIDE ghciState+ case maybeGhci of+ Just ghci -> liftIO $ do+ group <- getProcessGroupID+ old_int <- installHandler sigINT Ignore Nothing+ signalProcessGroup sigINT group+ installHandler sigINT old_int Nothing+ return ()+ Nothing -> return ()+#endif++debugContinue :: IDEAction+debugContinue = debugCommand ":continue" logOutputForLiveContext++debugDeleteAllBreakpoints :: IDEAction+debugDeleteAllBreakpoints = do+ debugCommand ":delete *" $ \output -> do+ logOutput output+ setBreakpointList []++debugDeleteBreakpoint :: String -> LogRef -> IDEAction+debugDeleteBreakpoint indexString lr = do+ debugCommand (":delete " ++ indexString) $ \output -> do+ logOutput output+ bl <- readIDE breakpointRefs+ setBreakpointList $ filter (/= lr) bl+ ideR <- ask+ return ()++debugForce :: IDEAction+debugForce = do+ maybeText <- selectedText+ case maybeText of+ Just text -> debugCommand (":force " ++ text) logOutput+ Nothing -> ideMessage Normal "Please select an expression in the editor"++debugHistory :: IDEAction+debugHistory = debugCommand ":history" logOutput++debugPrint :: IDEAction+debugPrint = do+ maybeText <- selectedText+ case maybeText of+ Just text -> debugCommand (":print " ++ text) logOutput+ Nothing -> ideMessage Normal "Please select an name in the editor"++debugSimplePrint :: IDEAction+debugSimplePrint = do+ maybeText <- selectedText+ case maybeText of+ Just text -> debugCommand (":force " ++ text) logOutput+ Nothing -> ideMessage Normal "Please select an name in the editor"++debugStep :: IDEAction+debugStep = do+ debugSetLiberalScope+ debugCommand ":step" logOutputForLiveContext++debugStepExpression :: IDEAction+debugStepExpression = do+ maybeText <- selectedText+ debugSetLiberalScope+ debugStepExpr maybeText++debugStepExpr :: Maybe String -> IDEAction+debugStepExpr maybeText = do+ case maybeText of+ Just text -> debugCommand (":step " ++ text) logOutputForLiveContext+ Nothing -> ideMessage Normal "Please select an expression in the editor"++debugStepLocal :: IDEAction+debugStepLocal = debugCommand ":steplocal" logOutputForLiveContext++debugStepModule :: IDEAction+debugStepModule = debugCommand ":stepmodule" logOutputForLiveContext++debugTrace :: IDEAction+debugTrace = do+ debugCommand ":trace" (\to -> do+ logOutputForLiveContext to+ triggerEventIDE TraceChanged+ return ())++debugTraceExpression :: IDEAction+debugTraceExpression = do+ maybeText <- selectedText+ debugSetLiberalScope+ debugTraceExpr maybeText++debugTraceExpr :: Maybe String -> IDEAction+debugTraceExpr maybeText =+ case maybeText of+ Just text -> debugCommand (":trace " ++ text) (\to -> do+ logOutputForLiveContext to+ triggerEventIDE TraceChanged+ return ())+ Nothing -> ideMessage Normal "Please select an expression in the editor"+++debugShowBindings :: IDEAction+debugShowBindings = debugCommand ":show bindings" logOutput++debugShowBreakpoints :: IDEAction+debugShowBreakpoints = debugCommand ":show breaks" logOutputForBreakpoints++debugShowContext :: IDEAction+debugShowContext = debugCommand ":show context" logOutputForLiveContext++debugShowModules :: IDEAction+debugShowModules = debugCommand ":show modules" $+ logOutputLines_ $ \log output -> liftIO $ do+ case output of+ ToolInput line -> appendLog log (line ++ "\n") InputTag+ ToolOutput line | ", interpreted )" `isSuffixOf` line+ -> appendLog log (line ++ "\n") LogTag+ ToolOutput line -> appendLog log (line ++ "\n") InfoTag+ ToolError line -> appendLog log (line ++ "\n") ErrorTag+ return ()++debugShowPackages :: IDEAction+debugShowPackages = debugCommand ":show packages" logOutput++debugShowLanguages :: IDEAction+debugShowLanguages = debugCommand ":show languages" logOutput++debugInformation :: IDEAction+debugInformation = do+ maybeText <- selectedText+ case maybeText of+ Just text -> do+ debugSetLiberalScope+ debugCommand (":info "++text) logOutput+ Nothing -> ideMessage Normal "Please select a name in the editor"++debugKind :: IDEAction+debugKind = do+ maybeText <- selectedText+ case maybeText of+ Just text -> do+ debugSetLiberalScope+ debugCommand (":kind "++text) logOutput+ Nothing -> ideMessage Normal "Please select a type in the editor"++debugType :: IDEAction+debugType = do+ maybeText <- selectedText+ case maybeText of+ Just text -> do+ debugSetLiberalScope+ debugCommand (":type "++text) logOutput+ Nothing -> ideMessage Normal "Please select an expression in the editor"++debugSetBreakpoint :: IDEAction+debugSetBreakpoint = do+ maybeModuleName <- selectedModuleName+ case maybeModuleName of+ Just moduleName -> do+ -- ### debugCommand (":add *"++moduleName) $ logOutputForBuild True+ maybeText <- selectedText+ case maybeText of+ Just text -> do+ debugCommand (":module *" ++ moduleName) logOutput+ debugCommand (":break " ++ text) logOutputForSetBreakpoint+ Nothing -> do+ maybeLocation <- selectedLocation+ case maybeLocation of+ Just (line, lineOffset) ->+ debugCommand (":break " ++ moduleName ++ " " ++ (show (line+1)) ++ " " +++ (show lineOffset)) logOutputForSetBreakpoint+ Nothing -> ideMessage Normal "Unknown error setting breakpoint"+ ref <- ask+ return ()+ Nothing -> ideMessage Normal "Please select module file in the editor"++interactiveFlag :: String -> Bool -> String+interactiveFlag name f = (if f then "-f" else "-fno-") ++ name++printEvldWithShowFlag :: Bool -> String+printEvldWithShowFlag = interactiveFlag "print-evld-with-show"++breakOnExceptionFlag :: Bool -> String+breakOnExceptionFlag = interactiveFlag "break-on-exception"++breakOnErrorFlag :: Bool -> String+breakOnErrorFlag = interactiveFlag "break-on-error"++printBindResultFlag :: Bool -> String+printBindResultFlag = interactiveFlag "print-bind-result"++interactiveFlags :: Prefs -> [String]+interactiveFlags prefs =+ (printEvldWithShowFlag $ printEvldWithShow prefs)+ : (breakOnExceptionFlag $ breakOnException prefs)+ : (breakOnErrorFlag $ breakOnError prefs)+ : [printBindResultFlag $ printBindResult prefs]++debugSet :: (Bool -> String) -> Bool -> IDEAction+debugSet flag value = do+ debugCommand (":set "++(flag value)) logOutput++debugSetPrintEvldWithShow :: Bool -> IDEAction+debugSetPrintEvldWithShow = debugSet printEvldWithShowFlag++debugSetBreakOnException :: Bool -> IDEAction+debugSetBreakOnException = debugSet breakOnExceptionFlag++debugSetBreakOnError :: Bool -> IDEAction+debugSetBreakOnError = debugSet breakOnErrorFlag++debugSetPrintBindResult :: Bool -> IDEAction+debugSetPrintBindResult = debugSet printBindResultFlag++
src/IDE/FileUtils.hs view
@@ -11,6 +11,7 @@ , getCollectorPath , getSysLibDir , moduleNameFromFilePath+, moduleNameFromFilePath' , findKnownPackages , isSubPath , findSourceFile@@ -45,7 +46,10 @@ openBrowser :: String -> IDEAction openBrowser url = do prefs' <- readIDE prefs- liftIO $ runProcess (browser prefs') [url] Nothing Nothing Nothing Nothing Nothing+ liftIO (catch (do+ runProcess (browser prefs') [url] Nothing Nothing Nothing Nothing Nothing+ return ())+ (\ _ -> sysMessage Normal ("Can't find browser executable " ++ browser prefs'))) return () -- | Returns True if the second path is a location which starts with the first path@@ -183,31 +187,32 @@ exists <- doesFileExist fp if exists then do- str <- readFile fp- let unlitRes = if takeExtension fp == ".lhs"- then unlit fp str- else Left str- case unlitRes of- Right err -> do- sysMessage Normal $show err- return Nothing- Left str' -> do- let parseRes = parse moduleNameParser fp str'- case parseRes of- Left err -> do- sysMessage Normal $show err- return Nothing- Right str -> do- let res = simpleParse str- case res of- Nothing -> do- sysMessage Normal $ "FileUtils>>moduleNameFromFilePath " ++- "Can't parse module name " ++ str- return Nothing- Just mn -> return (Just mn)+ str <- readFile fp+ moduleNameFromFilePath' fp str else return Nothing) $ \ _ -> return Nothing +moduleNameFromFilePath' :: FilePath -> String -> IO (Maybe ModuleName)+moduleNameFromFilePath' fp str = do+ let unlitRes = if takeExtension fp == ".lhs"+ then unlit fp str+ else Left str+ case unlitRes of+ Right err -> do+ sysMessage Normal $show err+ return Nothing+ Left str' -> do+ let parseRes = parse moduleNameParser fp str'+ case parseRes of+ Left err -> do+ return Nothing+ Right str -> do+ let res = simpleParse str+ case res of+ Nothing -> do+ return Nothing+ Just mn -> return (Just mn)+ lexer = haskell lexeme = P.lexeme lexer whiteSpace = P.whiteSpace lexer@@ -221,8 +226,6 @@ whiteSpace symbol "module" str <- lexeme mident--- skipMany anyChar--- eof return str <?> "module identifier"
src/IDE/Find.hs view
@@ -35,16 +35,29 @@ ) where import Graphics.UI.Gtk hiding (get)-import Graphics.UI.Gtk.SourceView import Graphics.UI.Gtk.Gdk.Events import Data.Maybe import Control.Monad.Reader-import Data.List import IDE.Core.State import IDE.Pane.SourceBuffer-import Data.Char (toLower,toUpper)+import Data.Char (toLower)+import Text.Regex.Posix.String (compile)+import Text.Regex.Posix+ (Regex(..), compNewline, compExtended, execBlank, compIgnoreCase)+import Data.Bits ((.|.))+import Data.List (nub, find, isPrefixOf)+import Data.Array ((!))+import Text.Regex.Base.RegexLike (matchAll)+import Text.Regex (subRegex)+import IDE.Tool (runTool)+import Control.Concurrent (forkIO)+import IDE.Pane.Grep+import GHC.Unicode (isAlphaNum)+import IDE.Package (getPackageDescriptionAndPath)+import Distribution.PackageDescription (allBuildInfo, hsSourceDirs) + data FindState = FindState { entryStr :: String , entryHist :: [String]@@ -53,7 +66,7 @@ , caseSensitive :: Bool , entireWord :: Bool , wrapAround :: Bool- , backward :: Bool+ , regex :: Bool , lineNr :: Int} deriving(Eq,Ord,Show,Read) @@ -68,7 +81,7 @@ entireWord <- getEntireWord fb wrapAround <- getWrapAround fb caseSensitive <- getCaseSensitive fb- backward <- getBackward fb+ regex <- getRegex fb return FindState{ entryStr = entryStr , entryHist = entryHist@@ -77,7 +90,7 @@ , caseSensitive = caseSensitive , entireWord = entireWord , wrapAround = wrapAround- , backward = backward+ , regex = regex , lineNr = lineNr} setFindState :: FindState -> IDEAction@@ -92,7 +105,7 @@ setEntireWord fb (entireWord fs) setWrapAround fb (wrapAround fs) setCaseSensitive fb (caseSensitive fs)- setBackward fb (backward fs)+ setRegex fb (regex fs) hideToolbar :: IDEAction hideToolbar = do@@ -100,7 +113,7 @@ case mbtb of Nothing -> return () Just tb -> do- modifyIDE_ (\ide -> return (ide{toolbar = (False,snd (toolbar ide))}))+ modifyIDE_ (\ide -> ide{toolbar = (False,snd (toolbar ide))}) liftIO $ widgetHideAll tb showToolbar :: IDEAction@@ -109,7 +122,7 @@ case mbtb of Nothing -> return () Just tb -> do- modifyIDE_ (\ide -> return (ide{toolbar = (True,snd (toolbar ide))}))+ modifyIDE_ (\ide -> ide{toolbar = (True,snd (toolbar ide))}) liftIO $ widgetShowAll tb toggleToolbar :: IDEAction@@ -122,7 +135,7 @@ hideFindbar :: IDEAction hideFindbar = do (_,mbfb) <- readIDE findbar- modifyIDE_ (\ide -> return (ide{findbar = (False,mbfb)}))+ modifyIDE_ (\ide -> ide{findbar = (False,mbfb)}) case mbfb of Nothing -> return () Just (fb,_) -> liftIO $ widgetHideAll fb@@ -130,7 +143,7 @@ showFindbar :: IDEAction showFindbar = do (_,mbfb) <- readIDE findbar- modifyIDE_ (\ide -> return (ide{findbar = (True,mbfb)}))+ modifyIDE_ (\ide -> ide{findbar = (True,mbfb)}) case mbfb of Nothing -> return () Just (fb,_) -> liftIO $ widgetShowAll fb@@ -152,15 +165,12 @@ constructFindReplace :: IDEM Toolbar constructFindReplace = reifyIDE $ \ ideR -> do toolbar <- toolbarNew+ tooltips <- tooltipsNew toolbarSetStyle toolbar ToolbarIcons+ toolbarSetIconSize toolbar IconSizeSmallToolbar closeButton <- toolButtonNewFromStock "gtk-close" toolbarInsert toolbar closeButton 0 - sep0 <- separatorToolItemNew- separatorToolItemSetDraw sep0 False- toolItemSetExpand sep0 True- toolbarInsert toolbar sep0 0- spinTool <- toolItemNew spinL <- spinButtonNewWithRange 1.0 1000.0 10.0 widgetSetName spinL "gotoLineEntry"@@ -176,6 +186,14 @@ sep1 <- separatorToolItemNew toolbarInsert toolbar sep1 0 + grepButton <- toolButtonNew (Nothing :: Maybe Widget) (Just "Grep")+ toolbarInsert toolbar grepButton 0+ grepButton `onToolButtonClicked` (reflectIDE (doGrep toolbar) ideR)+ tooltipsSetTip tooltips grepButton "Search in multiple files" ""++ sep1 <- separatorToolItemNew+ toolbarInsert toolbar sep1 0+ replaceAllButton <- toolButtonNew (Nothing :: Maybe Widget) (Just "Replace All") toolbarInsert toolbar replaceAllButton 0 @@ -197,34 +215,28 @@ sep2 <- separatorToolItemNew toolbarInsert toolbar sep2 0 - backwardButton <- toggleToolButtonNew- toolButtonSetLabel backwardButton (Just "Backward")- widgetSetName backwardButton "backwardButton"- toolbarInsert toolbar backwardButton 0+ nextButton <- toolButtonNewFromStock "gtk-go-forward"+ toolbarInsert toolbar nextButton 0+ tooltipsSetTip tooltips nextButton "Search for the next match in the current file" ""+ nextButton `onToolButtonClicked` (doSearch toolbar Forward ideR ) wrapAroundButton <- toggleToolButtonNew- toolButtonSetLabel wrapAroundButton (Just "Wrap around")+ toolButtonSetLabel wrapAroundButton (Just "Wrap") widgetSetName wrapAroundButton "wrapAroundButton" toolbarInsert toolbar wrapAroundButton 0-- entireWordButton <- toggleToolButtonNew- toolButtonSetLabel entireWordButton (Just "Entire word")- widgetSetName entireWordButton "entireWordButton"- toolbarInsert toolbar entireWordButton 0-- caseSensitiveButton <- toggleToolButtonNew- toolButtonSetLabel caseSensitiveButton (Just "Case sensitive")- widgetSetName caseSensitiveButton "caseSensitiveButton"- toolbarInsert toolbar caseSensitiveButton 0+ tooltipsSetTip tooltips wrapAroundButton "When selected searching will continue from the top when no more matches are found" "" - findButton <- toolButtonNewFromStock "gtk-find"- toolbarInsert toolbar findButton 0+ previousButton <- toolButtonNewFromStock "gtk-go-back"+ toolbarInsert toolbar previousButton 0+ tooltipsSetTip tooltips previousButton "Search for the previous match in the current file" ""+ previousButton `onToolButtonClicked` (doSearch toolbar Backward ideR ) entryTool <- toolItemNew entry <- entryNew widgetSetName entry "searchEntry" containerAdd entryTool entry widgetSetName entryTool "searchEntryTool"+ toolItemSetExpand entryTool True toolbarInsert toolbar entryTool 0 store <- listStoreNew []@@ -245,13 +257,32 @@ doSearch toolbar Forward ideR return True + regexButton <- toggleToolButtonNew+ toolButtonSetLabel regexButton (Just "Regex")+ widgetSetName regexButton "regexButton"+ toolbarInsert toolbar regexButton 0+ regexButton `onToolButtonClicked` (doSearch toolbar Insert ideR)+ tooltipsSetTip tooltips regexButton "When selected the search string is used as a regular expression" ""++ entireWordButton <- toggleToolButtonNew+ toolButtonSetLabel entireWordButton (Just "Words")+ widgetSetName entireWordButton "entireWordButton"+ toolbarInsert toolbar entireWordButton 0+ entireWordButton `onToolButtonClicked` (doSearch toolbar Insert ideR)+ tooltipsSetTip tooltips entireWordButton "When selected only entire words are matched" ""++ caseSensitiveButton <- toggleToolButtonNew+ toolButtonSetLabel caseSensitiveButton (Just "c. S.")+ widgetSetName caseSensitiveButton "caseSensitiveButton"+ toolbarInsert toolbar caseSensitiveButton 0+ caseSensitiveButton `onToolButtonClicked` (doSearch toolbar Insert ideR)+ tooltipsSetTip tooltips caseSensitiveButton "When selected the search is case sensitive" ""+ labelTool <- toolItemNew- label <- labelNew (Just "Search: ")+ label <- labelNew (Just "Find: ") containerAdd labelTool label toolbarInsert toolbar labelTool 0 - findButton `onToolButtonClicked` (doSearch toolbar Forward ideR )- entry `afterInsertText` (\t i -> do doSearch toolbar Insert ideR return i)@@ -278,8 +309,7 @@ spinL `afterFocusIn` (\ _ -> (reflectIDE (inActiveBufContext True $ \_ gtkbuf currentBuffer _ -> do max <- textBufferGetLineCount gtkbuf spinButtonSetRange spinL 1.0 (fromIntegral max)- return True) ideR ))-+ return True) ideR)) spinL `afterEntryActivate` (reflectIDE (inActiveBufContext () $ \_ gtkbuf currentBuffer _ -> do line <- spinButtonGetValueAsInt spinL@@ -296,13 +326,13 @@ set toolbar [ toolbarChildHomogeneous wrapAroundButton := False ] set toolbar [ toolbarChildHomogeneous entireWordButton := False ] set toolbar [ toolbarChildHomogeneous caseSensitiveButton := False ]- set toolbar [ toolbarChildHomogeneous backwardButton := False ]+ set toolbar [ toolbarChildHomogeneous regexButton := False ] set toolbar [ toolbarChildHomogeneous replaceAllButton := False ] set toolbar [ toolbarChildHomogeneous labelTool := False ] set toolbar [ toolbarChildHomogeneous labelTool2 := False ] set toolbar [ toolbarChildHomogeneous labelTool3 := False ] - reflectIDE (modifyIDE_ (\ide -> return ide{findbar = (False,Just (toolbar,store))})) ideR+ reflectIDE (modifyIDE_ (\ide -> ide{findbar = (False,Just (toolbar,store))})) ideR return toolbar where getOut = reflectIDE $ do hideFindbar@@ -321,17 +351,50 @@ entireWord <- getEntireWord fb caseSensitive <- getCaseSensitive fb wrapAround <- getWrapAround fb- res <- reflectIDE (editFind entireWord caseSensitive wrapAround search "" hint) ideR- if res || null search- then do- widgetModifyBase entry StateNormal white- widgetModifyText entry StateNormal black- else do- widgetModifyBase entry StateNormal red- widgetModifyText entry StateNormal white+ regex <- getRegex fb+ mbExpAndMatchIndex <- liftIO $ regexAndMatchIndex caseSensitive entireWord regex search+ case mbExpAndMatchIndex of+ Just (exp, matchIndex) -> do+ res <- reflectIDE (editFind entireWord caseSensitive wrapAround regex search "" hint) ideR+ if res || null search+ then do+ widgetModifyBase entry StateNormal white+ widgetModifyText entry StateNormal black+ else do+ widgetModifyBase entry StateNormal red+ widgetModifyText entry StateNormal white+ Nothing -> do+ if null search+ then do+ widgetModifyBase entry StateNormal white+ widgetModifyText entry StateNormal black+ else do+ widgetModifyBase entry StateNormal orange+ widgetModifyText entry StateNormal black reflectIDE (addToHist search) ideR return () +doGrep :: Toolbar -> IDEAction+doGrep fb = do+ ideR <- ask+ entry <- liftIO $ getFindEntry fb+ search <- liftIO $ entryGetText (castToEntry entry)+ entireWord <- liftIO $ getEntireWord fb+ caseSensitive <- liftIO $ getCaseSensitive fb+ wrapAround <- liftIO $ getWrapAround fb+ regex <- liftIO $ getRegex fb+ let (regexString, _) = regexStringAndMatchIndex entireWord regex search+ mbPD <- getPackageDescriptionAndPath+ case mbPD of+ Nothing -> ideMessage Normal "No package description"+ Just (pd,cabalPath) -> do+ let srcPaths = nub $ concatMap hsSourceDirs $ allBuildInfo pd+ liftIO $ forkIO $ do+ (output, pid) <- runTool "grep" ((if caseSensitive then [] else ["-i"])+ ++ ["-r", "-E", "-n", "--exclude=*~", regexString] ++ srcPaths)+ reflectIDE (setGrepResults output) ideR+ return ()+ matchFunc :: ListStore String -> String -> TreeIter -> IO Bool matchFunc model str iter = do tp <- treeModelGetPath model iter@@ -364,7 +427,8 @@ entireWord <- getEntireWord fb caseSensitive <- getCaseSensitive fb wrapAround <- getWrapAround fb- found <- reflectIDE (editReplace entireWord caseSensitive wrapAround search replace hint)+ regex <- getRegex fb+ found <- reflectIDE (editReplace entireWord caseSensitive wrapAround regex search replace hint) ideR return () @@ -378,111 +442,166 @@ entireWord <- getEntireWord fb caseSensitive <- getCaseSensitive fb wrapAround <- getWrapAround fb- found <- reflectIDE (editReplaceAll entireWord caseSensitive wrapAround search replace hint)+ regex <- getRegex fb+ found <- reflectIDE (editReplaceAll entireWord caseSensitive wrapAround regex search replace hint) ideR return () -editFind :: Bool -> Bool -> Bool -> String -> String -> SearchHint -> IDEM Bool-editFind entireWord caseSensitive wrapAround search dummy hint =- let searchflags = (if caseSensitive then [] else [toEnum 4]) ++ [toEnum 1,toEnum 2] in- if null search- then return False- else inActiveBufContext' False $ \_ gtkbuf currentBuffer _ -> liftIO $ do- i1 <- textBufferGetStartIter gtkbuf- i2 <- textBufferGetEndIter gtkbuf- textBufferRemoveTagByName gtkbuf "found" i1 i2- startMark <- textBufferGetInsert gtkbuf- st1 <- textBufferGetIterAtMark gtkbuf startMark- mbsr2 <-- if hint == Backward- then do- textIterBackwardChar st1- textIterBackwardChar st1- mbsr <- backSearch st1 search searchflags entireWord searchflags- case mbsr of- Nothing ->- if wrapAround- then do backSearch i2 search searchflags entireWord searchflags- else return Nothing- Just (start,end) -> return (Just (start,end))- else do- if hint == Forward- then textIterForwardChar st1- else return True- mbsr <- forwardSearch st1 search searchflags entireWord searchflags- case mbsr of- Nothing ->- if wrapAround- then do forwardSearch i1 search searchflags entireWord searchflags- else return Nothing- Just (start,end) -> return (Just (start,end))- case mbsr2 of- Just (start,end) -> do --found- --widgetGrabFocus sourceView- textViewScrollToIter (sourceView currentBuffer) start 0.2 Nothing- textBufferApplyTagByName gtkbuf "found" start end- textBufferPlaceCursor gtkbuf start- return True- Nothing -> return False+editFind :: Bool -> Bool -> Bool -> Bool -> String -> String -> SearchHint -> IDEM Bool+editFind entireWord caseSensitive wrapAround regex search dummy hint = do+ mbExpAndMatchIndex <- liftIO $ regexAndMatchIndex caseSensitive entireWord regex search+ case mbExpAndMatchIndex of+ Nothing -> return False+ Just (exp, matchIndex) -> editFind' exp matchIndex wrapAround dummy hint++editFind' :: Regex -> Int -> Bool -> String -> SearchHint -> IDEM Bool+editFind' exp matchIndex wrapAround dummy hint =+ inActiveBufContext' False $ \_ gtkbuf currentBuffer _ -> liftIO $ do+ i1 <- textBufferGetStartIter gtkbuf+ i2 <- textBufferGetEndIter gtkbuf+ textBufferRemoveTagByName gtkbuf "found" i1 i2+ startMark <- textBufferGetInsert gtkbuf+ st1 <- textBufferGetIterAtMark gtkbuf startMark+ mbsr2 <- liftIO $ do+ if hint == Backward+ then do+ textIterBackwardChar st1+ textIterBackwardChar st1+ mbsr <- backSearch exp matchIndex st1+ case mbsr of+ Nothing ->+ if wrapAround+ then do backSearch exp matchIndex i2+ else return Nothing+ Just (start,end) -> return (Just (start,end))+ else do+ if hint == Forward+ then textIterForwardChar st1+ else return True+ mbsr <- forwardSearch exp matchIndex st1+ case mbsr of+ Nothing ->+ if wrapAround+ then do forwardSearch exp matchIndex i1+ else return Nothing+ Just (start,end) -> return (Just (start,end))+ case mbsr2 of+ Just (start,end) -> do --found+ --widgetGrabFocus sourceView+ textViewScrollToIter (sourceView currentBuffer) start 0.2 Nothing+ textBufferApplyTagByName gtkbuf "found" start end+ textBufferPlaceCursor gtkbuf start+ return True+ Nothing -> return False where- backSearch iter string flags entireWord searchflags = do- mbsr <- sourceIterBackwardSearch iter search searchflags Nothing- case mbsr of- Nothing -> return Nothing- Just (iter1,iter2) ->- if entireWord- then do- b1 <- textIterStartsWord iter1- b2 <- textIterEndsWord iter2- if b1 && b2 then return $Just (iter1,iter2) else return Nothing- else return (Just (iter1,iter2))- forwardSearch iter string flags entireWord searchflags = do- mbsr <- sourceIterForwardSearch iter search searchflags Nothing- case mbsr of- Nothing -> return Nothing- Just (iter1,iter2) ->- if entireWord- then do- b1 <- textIterStartsWord iter1- b2 <- textIterEndsWord iter2- if b1 && b2 then return $Just (iter1,iter2) else return Nothing- else return $Just (iter1,iter2)+ backSearch exp matchIndex iter = do+ gtkbuf <- textIterGetBuffer iter+ offset <- textIterGetOffset iter+ findMatch exp matchIndex gtkbuf (<= offset) True -editReplace :: Bool -> Bool -> Bool -> String -> String -> SearchHint -> IDEM Bool-editReplace entireWord caseSensitive wrapAround search replace hint =- editReplace' entireWord caseSensitive wrapAround search replace hint True+ forwardSearch exp matchIndex iter = do+ gtkbuf <- textIterGetBuffer iter+ offset <- textIterGetOffset iter+ findMatch exp matchIndex gtkbuf (>= offset) False -editReplace' :: Bool -> Bool -> Bool -> String -> String -> SearchHint -> Bool -> IDEM Bool-editReplace' entireWord caseSensitive wrapAround search replace hint mayRepeat =+regexAndMatchIndex :: Bool -> Bool -> Bool -> String -> IO (Maybe (Regex, Int))+regexAndMatchIndex caseSensitive entireWord regex string = do+ if null string+ then return Nothing+ else do+ let (regexString, index) = regexStringAndMatchIndex entireWord regex string+ mbRegex <- compileRegex caseSensitive regexString+ return $ maybe Nothing (Just . (flip (,) index)) mbRegex++regexStringAndMatchIndex :: Bool -> Bool -> String -> (String, Int)+regexStringAndMatchIndex entireWord regex string =+ -- Escape non regex string+ let regexString = if regex+ then string+ else foldl (\s c -> s ++ if isAlphaNum c then [c] else ['\\', c]) "" string in+ -- Regular expression with word filter if needed+ if entireWord+ then ("(^|[^a-zA-Z0-9])(" ++ regexString ++ ")($|[^a-zA-Z0-9])", 2)+ else (regexString, 0)++findMatch :: Regex -> Int -> TextBuffer -> (Int -> Bool) -> Bool -> IO (Maybe (TextIter, TextIter))+findMatch exp matchIndex gtkbuf offsetPred findLast = do+ iterStart <- textBufferGetStartIter gtkbuf+ iterEnd <- textBufferGetEndIter gtkbuf+ text <- textBufferGetText gtkbuf iterStart iterEnd True+ let matches = (if findLast then reverse else id) (matchAll exp text)+ case find (offsetPred . fst . (!matchIndex)) matches of+ Just matches -> do+ iter1 <- textIterCopy iterStart+ textIterForwardChars iter1 (fst (matches!matchIndex))+ iter2 <- textIterCopy iter1+ textIterForwardChars iter2 (snd (matches!matchIndex))+ return $ Just (iter1, iter2)+ Nothing -> return Nothing++editReplace :: Bool -> Bool -> Bool -> Bool -> String -> String -> SearchHint -> IDEM Bool+editReplace entireWord caseSensitive wrapAround regex search replace hint =+ editReplace' entireWord caseSensitive wrapAround regex search replace hint True++editReplace' :: Bool -> Bool -> Bool -> Bool -> String -> String -> SearchHint -> Bool -> IDEM Bool+editReplace' entireWord caseSensitive wrapAround regex 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- if compare str1 search caseSensitive- then do- 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- if r- then editReplace' entireWord caseSensitive wrapAround search- replace hint False- else return False+ insertMark <- liftIO $ textBufferGetInsert gtkbuf+ iter <- liftIO $ textBufferGetIterAtMark gtkbuf insertMark+ offset <- liftIO $ textIterGetOffset iter+ mbExpAndMatchIndex <- liftIO $ regexAndMatchIndex caseSensitive entireWord regex search+ case mbExpAndMatchIndex of+ Just (exp, matchIndex) -> do+ match <- liftIO $ findMatch exp matchIndex gtkbuf (== offset) False+ case match of+ Just (iterStart, iterEnd) -> do+ old <- liftIO $ textIterGetText iterStart iterEnd+ mbText <- liftIO $ replacementText regex old replace+ case mbText of+ Just text -> do+ liftIO $ textBufferDelete gtkbuf iterStart iterEnd+ liftIO $ textBufferInsert gtkbuf iterStart text+ Nothing -> do+ sysMessage Normal+ "Should never happen. findMatch worked but repleacementText failed"+ return ()+ editFind entireWord caseSensitive wrapAround regex search "" hint+ Nothing -> do+ r <- editFind entireWord caseSensitive wrapAround regex search "" hint+ if r+ then editReplace' entireWord caseSensitive wrapAround regex search+ replace hint False+ else return False+ Nothing -> return False where- compare s1 s2 True = s1 == s2- compare s1 s2 False = map toUpper s1 == map toUpper s2+ replacementText False old replace = return $ Just replace+ replacementText True old replace = do+ mbExp <- compileRegex caseSensitive search+ case mbExp of+ Just exp -> return $ Just $ subRegex exp old replace+ Nothing -> return Nothing -editReplaceAll :: Bool -> Bool -> Bool -> String -> String -> SearchHint -> IDEM Bool-editReplaceAll entireWord caseSensitive wrapAround search replace hint = do- res <- editReplace' entireWord caseSensitive False search replace hint True+editReplaceAll :: Bool -> Bool -> Bool -> Bool -> String -> String -> SearchHint -> IDEM Bool+editReplaceAll entireWord caseSensitive wrapAround regex search replace hint = do+ res <- editReplace' entireWord caseSensitive False regex search replace hint True if res- then editReplaceAll entireWord caseSensitive False search replace hint+ then editReplaceAll entireWord caseSensitive False regex search replace hint else return False -red = Color 640000 10000 10000+compileRegex :: Bool -> String -> IO (Maybe Regex)+compileRegex caseSense searchString = do+ res <- compile ((if caseSense then id else (compIgnoreCase .|.))+ (compExtended .|. compNewline))+ execBlank searchString+ case res of+ Left err -> do+ sysMessage Normal (show err)+ return Nothing+ Right regex -> return $ Just regex+++red = Color 64000 10000 10000+orange = Color 64000 48000 0 white = Color 64000 64000 64000 black = Color 0 0 0 @@ -540,11 +659,11 @@ Just w -> return w _ -> throwIDE "Find>>getWidget not found(2)" -getEntireWord, getWrapAround, getCaseSensitive :: Toolbar -> IO Bool+getEntireWord, getWrapAround, getCaseSensitive, getRegex :: Toolbar -> IO Bool getEntireWord = getSelection "entireWordButton" getWrapAround = getSelection "wrapAroundButton" getCaseSensitive = getSelection "caseSensitiveButton"-getBackward = getSelection "backwardButton"+getRegex = getSelection "regexButton" getSelection :: String -> Toolbar -> IO Bool getSelection str tb = do@@ -554,11 +673,11 @@ [w] -> toggleToolButtonGetActive (castToToggleToolButton w) _ -> throwIDE "Find>>getIt widget not found" -setEntireWord, setWrapAround, setCaseSensitive, setBackward :: Toolbar -> Bool -> IO ()+setEntireWord, setWrapAround, setCaseSensitive, setRegex :: Toolbar -> Bool -> IO () setEntireWord = setSelection "entireWordButton" setWrapAround = setSelection "wrapAroundButton" setCaseSensitive = setSelection "caseSensitiveButton"-setBackward = setSelection "backwardButton"+setRegex = setSelection "regexButton" setSelection :: String -> Toolbar -> Bool -> IO () setSelection str tb bool = do
src/IDE/GUIHistory.hs view
@@ -25,7 +25,6 @@ import IDE.Core.State import IDE.Pane.Modules import IDE.Pane.Info-import Control.Event import Control.Monad.Reader recordHistory :: GUIHistory -> IDEAction@@ -34,9 +33,8 @@ if b || (n >= 0 && fst entry == fst (l !! n)) then return () else do- modifyIDE_ (\ide -> return ide{guiHistory = (b,entry:(drop n l),0)})- st <- ask- triggerEvent st (Sensitivity+ modifyIDE_ (\ide -> ide{guiHistory = (b,entry:(drop n l),0)})+ triggerEventIDE (Sensitivity [(SensitivityForwardHist,False),(SensitivityBackwardHist,0 < length (drop n l) - 1)]) return () -- liftIO $ putStrLn $ "record n : " ++ show 0 -- ++ " hist: " ++ show (entry:(drop n l))@@ -49,9 +47,8 @@ (l,n) | n + 1 >= length l -> return () | otherwise -> do withoutRecordingDo (activateHistory (snd (l !! n)))- modifyIDE_ (\ide -> return ide{guiHistory = (b,l, n + 1)})- st <- ask- triggerEvent st (Sensitivity+ modifyIDE_ (\ide -> ide{guiHistory = (b,l, n + 1)})+ triggerEventIDE (Sensitivity [(SensitivityForwardHist,(n + 1) > 0),(SensitivityBackwardHist,(n + 1) < (length l) - 1)]) return () -- liftIO $ putStrLn $ "back n : " ++ show (n + 1) -- ++ " hist: " ++ show l@@ -64,9 +61,8 @@ (l,n) | n < 1 -> return () | otherwise -> do withoutRecordingDo (activateHistory (fst (l !! n)))- modifyIDE_ (\ide -> return ide{guiHistory = (b,l, n - 1)})- st <- ask- triggerEvent st (Sensitivity+ modifyIDE_ (\ide -> ide{guiHistory = (b,l, n - 1)})+ triggerEventIDE (Sensitivity [(SensitivityForwardHist,(n - 1) > 0),(SensitivityBackwardHist,(n - 1) < (length l) - 1)]) return () -- liftIO $ putStrLn $ "forward n : " ++ show (n - 1) -- ++ " hist: " ++ show l
+ src/IDE/Group/Debugger.hs view
@@ -0,0 +1,72 @@+-----------------------------------------------------------------------------+--+-- Module : IDE.Group.Debugger+-- Copyright : 2007-2009 Juergen Nicklisch-Franken, Hamish Mackenzie+-- License : GPL+--+-- Maintainer : maintainer@leksah.org+-- Stability : provisional+-- Portability :+--+-- |+--+-----------------------------------------------------------------------------++module IDE.Group.Debugger (+showDebugger+) where++import IDE.Core.State+ (getNotebook, viewSplit', newGroupOrBringToFront, IDEAction(..))+import Graphics.UI.Frame.Panes+ (PaneDirection(..),+ PanePathElement(..),+ panePathForGroup)+import IDE.Pane.SourceBuffer+ (newTextBuffer, bufferName, allBuffers)+import Graphics.UI.Editor.Parameters (Direction(..))+import Control.Monad.Trans (liftIO)+import Graphics.UI.Gtk (notebookSetShowTabs, notebookSetTabPos)+import Graphics.UI.Gtk.General.Enums (PositionType(..))+import IDE.Pane.Variables (showVariables')+import IDE.Pane.Breakpoints (showBreakpointList')+import IDE.Pane.Trace(showTrace')+import Control.Monad (when)++showDebugger :: IDEAction+showDebugger = do+ pp <- panePathForGroup "*Debug"+ ret <- newGroupOrBringToFront "Debug" pp+ bufs <- allBuffers+ case ret of+ (Just rpp, True) -> do+ viewSplit' rpp Horizontal+ viewSplit' (rpp ++ [SplitP TopP]) Horizontal+ let lowerP = rpp ++ [SplitP BottomP]+ let middleP = rpp ++ [SplitP TopP,SplitP BottomP]+ let upperP = rpp ++ [SplitP TopP,SplitP TopP]+ lower <- getNotebook lowerP+ middle <- getNotebook middleP+ upper <- getNotebook upperP+ liftIO $ do+ notebookSetTabPos lower PosTop+ notebookSetTabPos middle PosTop+ notebookSetTabPos upper PosTop+ notebookSetShowTabs upper False+ showBreakpointList' middleP+ showVariables' middleP+ showTrace' lowerP+ when (null $ filter (\b -> bufferName b == "_Eval.hs") bufs) $+ newTextBuffer upperP "_Eval.hs" Nothing >> return ()+ return ()+ (Just rpp, False) -> do+ let lowerP = rpp ++ [SplitP BottomP]+ let middleP = rpp ++ [SplitP TopP,SplitP BottomP]+ let upperP = rpp ++ [SplitP TopP,SplitP TopP]+ showBreakpointList' middleP+ showVariables' middleP+ showTrace' lowerP+ when (null $ filter (\b -> bufferName b == "_Eval.hs") bufs) $+ newTextBuffer upperP "_Eval.hs" Nothing >> return ()+ return ()+ _ -> return ()
src/IDE/ImportTool.hs view
@@ -27,7 +27,7 @@ import Text.PrettyPrint (render) import Distribution.Text (disp) import IDE.Pane.SourceBuffer- (inActiveBufContext', selectSourceBuf)+ (fileSave, inActiveBufContext', selectSourceBuf) import Graphics.UI.Gtk import IDE.SourceCandy (getCandylessText) import Text.ParserCombinators.Parsec.Language (haskellStyle)@@ -49,12 +49,18 @@ import GHC hiding (ModuleName) import Text.ParserCombinators.Parsec import qualified Text.ParserCombinators.Parsec.Token as P- (operator, dot, identifier, symbol, whiteSpace, lexeme,makeTokenParser)+ (whiteSpace,+ operator,+ dot,+ identifier,+ symbol,+ lexeme,+ makeTokenParser) import Graphics.UI.Editor.Simple (okCancelFields, staticListEditor) import Control.Event (registerEvent)+import Outputable (showSDoc, ppr) import Control.Monad.Trans (liftIO) import Control.Monad (foldM_, when)-import Outputable (ppr,showSDoc) @@ -64,43 +70,40 @@ prefs' <- readIDE prefs let buildInBackground = backgroundBuild prefs' when buildInBackground (- modifyIDE_ (\ide -> return (ide{prefs = prefs'{backgroundBuild = False}})))- errors <- readIDE errors+ modifyIDE_ (\ide -> ide{prefs = prefs'{backgroundBuild = False}}))+ errors <- readIDE errorRefs foldM_ addThis (True,[]) [ y | (x,y) <- nubBy (\ (p1,_) (p2,_) -> p1 == p2)- $ [(x,y) | (x,y) <- [((parseNotInScope . errDescription) e, e) | e <- errors]],+ $ [(x,y) | (x,y) <- [((parseNotInScope . refDescription) e, e) | e <- errors]], isJust x] when buildInBackground $- modifyIDE_ (\ide -> return (ide{prefs = prefs'{backgroundBuild = True}}))+ modifyIDE_ (\ide -> ide{prefs = prefs'{backgroundBuild = True}}) where- addThis :: (Bool,[Descr]) -> ErrorSpec -> IDEM (Bool,[Descr])+ addThis :: (Bool,[Descr]) -> LogRef -> 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+ errors' <- readIDE errorRefs+ currentErr' <- readIDE currentError 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"+ Just ref -> do+ addImport ref [] >> return () -- | 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 :: LogRef -> [Descr] -> IDEM (Bool, [Descr]) addImport error descrList =- case parseNotInScope (errDescription error) of+ case parseNotInScope (refDescription error) of Nothing -> return (True,descrList) Just nis -> do currentInfo' <- readIDE currentInfo@@ -114,7 +117,8 @@ return (True,descrList) descr : [] -> addImport' nis (filePath error) descr descrList list -> do- mbDescr <- liftIO $ selectModuleDialog list (id' nis)+ window' <- getMainWindow+ mbDescr <- liftIO $ selectModuleDialog window' list (id' nis) (if null descrList then Nothing else Just (head descrList))@@ -144,7 +148,7 @@ Nothing -> do ideMessage Normal ("Can't parse module header " ++ filePath) return (False, descrList)- Just imports ->+ Just HsModule{ hsmodImports = imports } -> case filter qualifyAsImportStatement imports of [] -> let newLine = showSDoc (ppr newImpDecl) ++ "\n" lastLoc = foldr max noSrcSpan (map getLoc imports)@@ -159,6 +163,8 @@ liftIO $ do i1 <- textBufferGetIterAtLine gtkbuf lineSel textBufferInsert gtkbuf i1 newLine+ fileSave False+ liftIO $ textBufferSetModified gtkbuf True return (True,descr : descrList) l@(impDecl:_) -> let newImpDecl = addToDecl (unLoc impDecl)@@ -179,6 +185,8 @@ i2 <- textBufferGetIterAtLine gtkbuf (lineEnd) textBufferDelete gtkbuf i1 i2 textBufferInsert gtkbuf i1 newLine+ fileSave False+ liftIO $ textBufferSetModified gtkbuf True return (True, descr : descrList) where isHiding (Just (_,False)) = True@@ -351,8 +359,8 @@ (\ a b -> a) (staticListEditor ((nub . sort) list) id) -selectModuleDialog :: [Descr] -> String -> Maybe Descr -> IO (Maybe Descr)-selectModuleDialog list id mbDescr = do+selectModuleDialog :: Window -> [Descr] -> String -> Maybe Descr -> IO (Maybe Descr)+selectModuleDialog parentWindow list id mbDescr = do let selectionList = map (render . disp . modu . descrModu') list let mbSelectedString = case mbDescr of Nothing -> Nothing@@ -363,6 +371,7 @@ then str else head selectionList dia <- dialogNew+ windowSetTransientFor dia parentWindow upper <- dialogGetUpper dia lower <- dialogGetActionArea dia (widget,inj,ext,_) <- buildEditor (moduleFields selectionList id) realSelectionString
src/IDE/Leksah.hs view
@@ -20,13 +20,10 @@ ) where import Graphics.UI.Gtk-import Graphics.UI.Gtk.Gdk.Events-import qualified Graphics.UI.Gtk.Gdk.Events as GdkEvents import Control.Monad.Reader import Control.Concurrent import Data.IORef import Data.Maybe-import Data.List(sort) import qualified Data.Map as Map import System.Console.GetOpt import System.Environment@@ -34,10 +31,12 @@ import Config import Data.Version import Prelude hiding(catch)-import System.FilePath import System.Directory-import Debug.Trace +#if defined(darwin_HOST_OS)+import IDE.OSX+#endif+ import Paths_leksah import IDE.SaveSession import IDE.Core.State@@ -50,23 +49,17 @@ import IDE.Pane.Preferences import IDE.Keymap import IDE.Pane.SourceBuffer-import IDE.Metainfo.Provider import IDE.Metainfo.SourceCollector import IDE.Metainfo.InterfaceCollector-import IDE.Pane.Log-import IDE.Pane.Info-import IDE.Pane.Modules-import IDE.GUIHistory-import IDE.Pane.Search(setChoices,searchMetaGUI) import IDE.Find import Graphics.UI.Editor.Composite (filesEditor, maybeEditor) import Graphics.UI.Editor.Simple (fileEditor) --import Outputable (ppr,showSDoc) import IDE.Metainfo.GHCUtils (inGhcIO)-import IDE.NotebookFlipper (flipUp,flipDown) import IDE.Package (packageBuild)+import IDE.Metainfo.Provider (initInfo) --- ---------------------------------------------------------------------+-- -------------------------------------------------------------------- -- Command line options -- @@ -111,6 +104,7 @@ runMain = handleTopExceptions $ do args <- getArgs+ (o,_) <- ideOpts args let uninstalled = filter (\x -> case x of UninstalledProject _ -> True@@ -166,11 +160,10 @@ startGUI :: String -> Prefs -> IO () startGUI sessionFilename iprefs = do- trace "start gui called" $ return ()- st <- initGUI+ st <- unsafeInitGUIForThreadedRTS when rtsSupportsBoundThreads (sysMessage Normal "Linked with -threaded")- timeoutAddFull (yield >> return True) priorityHigh 25+ timeoutAddFull (yield >> return True) priorityHigh 100 mapM_ (sysMessage Normal) st uiManager <- uiManagerNew newIcons@@ -182,36 +175,40 @@ prefsPath <- getConfigFilePathForLoad "Default.prefs" prefs <- readPrefs prefsPath return (prefs,True)- keysPath <- getConfigFilePathForLoad $ keymapName startupPrefs ++ ".keymap"- keyMap <- parseKeymap keysPath- let accelActions = setKeymap (keyMap :: KeymapI) actions- specialKeys <- buildSpecialKeys keyMap accelActions candyPath <- getConfigFilePathForLoad (case sourceCandy startupPrefs of- Nothing -> "Default.candy"- Just name -> name ++ ".candy")+ Nothing -> "Default.candy"+ Just name -> name ++ ".candy") candySt <- parseCandy candyPath+ -- keystrokes+ keysPath <- getConfigFilePathForLoad $ keymapName iprefs ++ ".keymap"+ keyMap <- parseKeymap keysPath+ let accelActions = setKeymap (keyMap :: KeymapI) mkActions+ specialKeys <- buildSpecialKeys keyMap accelActions+ win <- windowNew- dataDir <- getDataDir- let iconPath = dataDir </> "data" </> "leksah.png"- iconExists <- doesFileExist iconPath- when iconExists $- windowSetIconFromFile win iconPath+ widgetSetName win "Leksah Main Window"+ let fs = FrameState+ { windows = [win]+ , uiManager = uiManager+ , panes = Map.empty+ , activePane = Nothing+ , paneMap = Map.empty+ , layout = (TerminalP Map.empty Nothing (-1) Nothing Nothing)+ , panePathFromNB = Map.empty+ } let ide = IDE- { window = win- , uiManager = uiManager- , panes = Map.empty- , activePane = Nothing+ { frameState = fs , recentPanes = []- , paneMap = Map.empty- , layout = (TerminalP Nothing (-1)) , specialKeys = specialKeys , specialKey = Nothing , candy = candySt , prefs = startupPrefs , activePack = Nothing- , errors = []- , currentErr = Nothing+ , projFilesCache = Map.empty+ , allLogRefs = []+ , currentHist = 0+ , currentEBC = (Nothing, Nothing, Nothing) , accessibleInfo = Nothing , currentInfo = Nothing , handlers = Map.empty@@ -221,42 +218,19 @@ , toolbar = (True,Nothing) , recentFiles = [] , recentPackages = []- , buildProcess = Nothing+ , runningTool = Nothing+ , ghciState = Nothing+ , completion = Nothing } ideR <- newIORef ide+ reflectIDE (initInfo :: IDEAction) ideR 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)- findbar <- reflectIDE (do- initInfo :: IDEAction- modifyIDE_ (\ide -> return (ide{toolbar = (True,Just toolbar)}))- constructFindReplace ) ideR- sep0 <- separatorToolItemNew- separatorToolItemSetDraw sep0 False- toolItemSetExpand sep0 True- toolbarInsert toolbar sep0 (-1)- closeButton <- toolButtonNewFromStock "gtk-close"- toolbarInsert toolbar closeButton (-1)- closeButton `onToolButtonClicked` do- reflectIDE hideToolbar ideR-- windowAddAccelGroup win acc- nb <- newNotebook+ reflectIDE (makeMenu uiManager accelActions menuDescription') ideR+ nb <- reflectIDE (newNotebook []) ideR afterSwitchPage nb (\i -> reflectIDE (handleNotebookSwitch nb i) ideR) widgetSetName nb $"root"- statusBar <- buildStatusbar ideR- vb <- vBoxNew False 1 -- Top-level vbox- widgetSetName vb "topBox"- toolbarSetStyle (castToToolbar (menus !! 1)) ToolbarIcons- boxPackStart vb (menus !! 0) PackNatural 0- boxPackStart vb (menus !! 1) PackNatural 0- boxPackStart vb nb PackGrow 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)- containerAdd win vb+ reflectIDE (instrumentWindow win startupPrefs (castToWidget nb)) ideR reflectIDE (do setCandyState (isJust (sourceCandy startupPrefs)) setBackgroundBuildToggled (backgroundBuild startupPrefs)@@ -264,13 +238,21 @@ let (x,y) = defaultSize startupPrefs windowSetDefaultSize win x y sessionPath <- getConfigFilePathForLoad sessionFilename- (tbv,fbv) <- reflectIDE (do- registerEvents menus- recoverSession sessionPath+ (tbv,fbv) <- reflectIDE (do+ registerEvents+ pair <- recoverSession sessionPath+ wins <- getWindows+ mapM_ instrumentSecWindow (tail wins)+ return pair ) ideR widgetShowAll win++#if defined(darwin_HOST_OS)+ updateMenu uiManager+#endif+ reflectIDE (do- ask >>= \ideR -> triggerEvent ideR UpdateRecent+ triggerEventIDE UpdateRecent if tbv then showToolbar else hideToolbar@@ -281,146 +263,15 @@ when isFirstStart $ do welcomePath <- getConfigFilePathForLoad $ "welcome.txt" reflectIDE (fileOpenThis welcomePath) ideR- reflectIDE (modifyIDE_ (\ide -> return ide{currentState = IsRunning})) ideR+ reflectIDE (modifyIDE_ (\ide -> ide{currentState = IsRunning})) ideR timeoutAddFull (do reflectIDE (do currentPrefs <- readIDE prefs when (backgroundBuild currentPrefs) $ packageBuild True) ideR- return True) priorityDefaultIdle 100-+ return True) priorityDefaultIdle 1000+ reflectIDE (triggerEvent ideR (Sensitivity [(SensitivityInterpreting, False)])) ideR mainGUI------- | Callback function for onKeyPress of the main window, so 'preprocess' any key----handleSpecialKeystrokes :: GdkEvents.Event -> IDEM Bool-handleSpecialKeystrokes (Key { eventKeyName = name, eventModifier = mods,- eventKeyVal = keyVal, eventKeyChar = mbChar}) = do- sb <- getSBSpecialKeys- prefs' <- readIDE prefs- case (name, mods) of- (tab, [Control]) | (tab == "Tab" || tab == "ISO_Left_Tab")- && useCtrlTabFlipping prefs' -> do- flipDown- return True- (tab, [Shift, Control]) | (tab == "Tab" || tab == "ISO_Left_Tab")- && useCtrlTabFlipping prefs' -> do- flipUp- return True- _ -> do- bs <- getCandyState- when bs (editKeystrokeCandy mbChar)- sk <- readIDE specialKey- sks <- readIDE specialKeys- return True- case sk of- Nothing ->- case Map.lookup (keyVal,sort mods) sks of- Nothing -> do- liftIO $statusbarPop sb 1- liftIO $statusbarPush sb 1 ""- return False- Just map -> do- let sym = printMods mods ++ name- liftIO $statusbarPop sb 1- liftIO $statusbarPush sb 1 sym- modifyIDE_ (\ide -> return (ide{specialKey = Just (map,sym)}))- return True- Just (map,sym) -> do- case Map.lookup (keyVal,sort mods) map of- Nothing -> do- liftIO $statusbarPop sb 1- liftIO $statusbarPush sb 1 $ sym ++ printMods mods ++ name ++ "?"- return ()- Just (AD actname _ _ _ ideAction _ _) -> do- liftIO $statusbarPop sb 1- liftIO $statusbarPush sb 1- $ sym ++ " " ++ printMods mods ++ name ++ "=" ++ actname- ideAction- modifyIDE_ (\ide -> return (ide{specialKey = Nothing}))- return True- where- printMods :: [Modifier] -> String- printMods [] = ""- printMods (m:r) = show m ++ printMods r-handleSpecialKeystrokes _ = return True------- | Register handlers for IDE events----registerEvents :: [Widget] -> IDEAction-registerEvents tbl = do- stRef <- ask- registerEvent stRef "LogMessage" (Left logHandler)- registerEvent stRef "SelectInfo" (Left siHandler)- registerEvent stRef "SelectIdent" (Left sidHandler)- registerEvent stRef "CurrentInfo" (Left ciuHandler)- registerEvent stRef "ActivePack" (Left apHandler)- registerEvent stRef "RecordHistory" (Left rhHandler)- registerEvent stRef "Sensitivity" (Left sHandler)- registerEvent stRef "DescrChoice" (Left dcHandler)- 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- (log :: IDELog) <- getLog- liftIO $ appendLog log s t- return e- logHandler _ = throwIDE "Leksah>>registerEvents: Impossible event"-- siHandler e@(SelectInfo str) = do- setSymbol str- return e- siHandler _ = throwIDE "Leksah>>registerEvents: Impossible event"-- sidHandler e@(SelectIdent id) = do- selectIdentifier id- return e- sidHandler _ = throwIDE "Leksah>>registerEvents: Impossible event"-- ciuHandler CurrentInfo = do- reloadKeepSelection- return CurrentInfo- ciuHandler _ = throwIDE "Leksah>>registerEvents: Impossible event"-- apHandler ActivePack = do- infoForActivePackage :: IDEAction- return ActivePack- apHandler _ = throwIDE "Leksah>>registerEvents: Impossible event"-- rhHandler rh@(RecordHistory h) = do- recordHistory h- return rh- rhHandler _ = throwIDE "Leksah>>registerEvents: Impossible event"-- sHandler s@(Sensitivity h) = do- setSensitivity h- return s- sHandler _ = throwIDE "Leksah>>registerEvents: Impossible event"-- dcHandler e@(DescrChoice descrs) = do- setChoices descrs- return e- dcHandler _ = throwIDE "Leksah>>registerEvents: Impossible event"-- smHandler e@(SearchMeta string) = searchMetaGUI string >> return e- smHandler _ = throwIDE "Leksah>>registerEvents: Impossible event"-- lsHandler e@(LoadSession fp) = loadSession fp >> return e- lsHandler _ = throwIDE "Leksah>>registerEvents: Impossible event"-- 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 [
+ src/IDE/LogRef.hs view
@@ -0,0 +1,522 @@+{-# OPTIONS_GHC -XScopedTypeVariables #-}+-----------------------------------------------------------------------------+--+-- Module : IDE.LogRef+-- Copyright : (c) Juergen Nicklisch-Franken, Hamish Mackenzie+-- License : GNU-GPL+--+-- Maintainer : <maintainer at leksah.org>+-- Stability : provisional+-- Portability : portable+--+--+-- | The packages methods of ide.+--+---------------------------------------------------------------------------------+++module IDE.LogRef (+ nextError+, previousError+, nextBreakpoint+, previousBreakpoint+, markLogRefs+, unmarkLogRefs+, defaultLineLogger+, logOutputLines+, logOutputLines_+, logOutput+, logOutputForBuild+, logOutputForBreakpoints+, logOutputForSetBreakpoint+, logOutputForLiveContext+, logOutputForHistoricContext+, selectRef+, setBreakpointList+, showSourceSpan+, srcSpanParser+) where++import Graphics.UI.Gtk+import Control.Monad.Reader+import Text.ParserCombinators.Parsec.Language+import Text.ParserCombinators.Parsec hiding(Parser)+import qualified Text.ParserCombinators.Parsec.Token as P++import IDE.Core.State+import IDE.Pane.SourceBuffer+import IDE.Pane.Log+import IDE.Tool+import System.FilePath (equalFilePath)+import System.Directory (canonicalizePath)+import Data.List (stripPrefix, elemIndex, isPrefixOf)+import SrcLoc+ (srcLocSpan, mkSrcLoc, mkSrcSpan, SrcSpan(..))+import FastString (mkFastString)+import Data.Maybe (catMaybes)+import Outputable (ppr, showSDoc)++showSourceSpan :: LogRef -> String+showSourceSpan = showSDoc . ppr . logRefSrcSpan+++selectRef :: Maybe LogRef -> IDEAction+selectRef (Just ref) = do+ logRefs <- readIDE allLogRefs+ case elemIndex ref logRefs of+ Nothing -> return ()+ Just index -> do+ mbBuf <- selectSourceBuf (filePath ref)+ case mbBuf of+ Just buf -> markRefInSourceBuf index buf ref True+ Nothing -> return ()+ log :: IDELog <- getLog+ liftIO $ markErrorInLog log (logLines ref)+selectRef Nothing = return ()++forOpenLogRefs :: (Int -> LogRef -> IDEBuffer -> IDEAction) -> IDEAction+forOpenLogRefs f = do+ logRefs <- readIDE allLogRefs+ allBufs <- allBuffers+ forM_ [0 .. ((length logRefs)-1)] (\index -> do+ let ref = logRefs !! index+ fpc <- liftIO $ canonicalizePath $ filePath ref+ forM_ (filter (\buf -> case (fileName buf) of+ Just fn -> equalFilePath fpc fn+ Nothing -> False) allBufs) (f index ref))++markLogRefs :: IDEAction+markLogRefs = do+ forOpenLogRefs $ \index logRef buf -> markRefInSourceBuf index buf logRef False++unmarkLogRefs :: IDEAction+unmarkLogRefs = do+ forOpenLogRefs $ \index logRef buf -> liftIO $ do+ gtkbuf <- textViewGetBuffer (sourceView buf)+ i1 <- textBufferGetStartIter gtkbuf+ i2 <- textBufferGetEndIter gtkbuf+ textBufferRemoveTagByName gtkbuf (show (logRefType logRef) ++ show index) i1 i2++setErrorList :: [LogRef] -> IDEAction+setErrorList errs = do+ unmarkLogRefs+ breaks <- readIDE breakpointRefs+ contexts <- readIDE contextRefs+ modifyIDE_ (\ide -> ide{allLogRefs = errs ++ breaks ++ contexts})+ setCurrentError Nothing+ markLogRefs+ triggerEventIDE ErrorChanged+ return ()++setBreakpointList :: [LogRef] -> IDEAction+setBreakpointList breaks = do+ ideR <- ask+ unmarkLogRefs+ errs <- readIDE errorRefs+ contexts <- readIDE contextRefs+ modifyIDE_ (\ide -> ide{allLogRefs = errs ++ breaks ++ contexts})+ setCurrentBreak Nothing+ markLogRefs+ triggerEventIDE BreakpointChanged+ return ()++addLogRefs :: [LogRef] -> IDEAction+addLogRefs refs = do+ ideR <- ask+ unmarkLogRefs+ modifyIDE_ (\ide -> ide{allLogRefs = (allLogRefs ide) ++ refs})+ setCurrentError Nothing+ markLogRefs+ triggerEventIDE ErrorChanged+ triggerEventIDE BreakpointChanged+ triggerEventIDE TraceChanged+ return ()++nextError :: IDEAction+nextError = do+ errs <- readIDE errorRefs+ currentError <- readIDE currentError+ if null errs+ then return ()+ else do+ let new = case currentError of+ Nothing -> 0+ Just ref ->+ case elemIndex ref errs of+ Nothing -> 0+ Just n | (n + 1) < length errs -> (n + 1)+ Just n -> n+ setCurrentError (Just $ errs!!new)+ selectRef $ Just (errs!!new)++previousError :: IDEAction+previousError = do+ errs <- readIDE errorRefs+ currentError <- readIDE currentError+ if null errs+ then return ()+ else do+ let new = case currentError of+ Nothing -> (length errs - 1)+ Just ref ->+ case elemIndex ref errs of+ Nothing -> (length errs - 1)+ Just n | n > 0 -> (n - 1)+ Just n -> 0+ setCurrentError (Just $ errs!!new)+ selectRef $ Just (errs!!new)++nextBreakpoint :: IDEAction+nextBreakpoint = do+ breaks <- readIDE breakpointRefs+ currentBreak <- readIDE currentBreak+ if null breaks+ then return ()+ else do+ let new = case currentBreak of+ Nothing -> 0+ Just ref ->+ case elemIndex ref breaks of+ Nothing -> 0+ Just n | (n + 1) < length breaks -> (n + 1)+ Just n -> n+ setCurrentBreak (Just $ breaks!!new)+ selectRef $ Just (breaks!!new)++previousBreakpoint :: IDEAction+previousBreakpoint = do+ breaks <- readIDE breakpointRefs+ currentBreak <- readIDE currentBreak+ if null breaks+ then return ()+ else do+ let new = case currentBreak of+ Nothing -> (length breaks - 1)+ Just ref ->+ case elemIndex ref breaks of+ Nothing -> (length breaks - 1)+ Just n | n > 0 -> (n - 1)+ Just n -> 0+ setCurrentBreak (Just $ breaks!!new)+ selectRef $ Just (breaks!!new)++nextContext :: IDEAction+nextContext = do+ contexts <- readIDE contextRefs+ currentContext <- readIDE currentContext+ if null contexts+ then return ()+ else do+ let new = case currentContext of+ Nothing -> 0+ Just ref ->+ case elemIndex ref contexts of+ Nothing -> 0+ Just n | (n + 1) < length contexts -> (n + 1)+ Just n -> n+ setCurrentContext (Just $ contexts!!new)+ selectRef $ Just (contexts!!new)++previousContext :: IDEAction+previousContext = do+ contexts <- readIDE contextRefs+ currentContext <- readIDE currentContext+ if null contexts+ then return ()+ else do+ let new = case currentContext of+ Nothing -> (length contexts - 1)+ Just ref ->+ case elemIndex ref contexts of+ Nothing -> (length contexts - 1)+ Just n | n > 0 -> (n - 1)+ Just n -> 0+ setCurrentContext (Just $ contexts!!new)+ selectRef $ Just (contexts!!new)++lastContext :: IDEAction+lastContext = do+ contexts <- readIDE contextRefs+ currentContext <- readIDE currentContext+ if null contexts+ then return ()+ else do+ let new = (last contexts)+ setCurrentContext (Just new)+ selectRef $ Just new++srcSpanParser :: CharParser () SrcSpan+srcSpanParser = try (do+ filePath <- fmap mkFastString $ many (noneOf ":")+ char ':'+ char '('+ beginLine <- int+ char ','+ beginCol <- int+ char ')'+ char '-'+ char '('+ endLine <- int+ char ','+ endCol <- int+ char ')'+ return $ mkSrcSpan (mkSrcLoc filePath beginLine beginCol)+ (mkSrcLoc filePath endLine endCol))+ <|> try (do+ filePath <- fmap mkFastString $ many (noneOf ":")+ char ':'+ line <- int+ char ':'+ beginCol <- int+ char '-'+ endCol <- int+ return $ mkSrcSpan (mkSrcLoc filePath line beginCol)+ (mkSrcLoc filePath line endCol))+ <|> try (do+ filePath <- fmap mkFastString $ many (noneOf ":")+ char ':'+ line <- int+ char ':'+ col <- int+ return $ srcLocSpan (mkSrcLoc filePath line col))+ <?> "srcLocParser"++data BuildError = BuildLine+ | EmptyLine+ | ErrorLine SrcSpan String+ | WarningLine String+ | OtherLine String++buildLineParser :: CharParser () BuildError+buildLineParser = try (do+ char '['+ int+ symbol "of"+ int+ char ']'+ many (anyChar)+ return BuildLine)+ <|> try (do+ span <- srcSpanParser+ char ':'+ whiteSpace+ text <- many anyChar+ return (ErrorLine span text))+ <|> try (do+ whiteSpace+ eof+ return EmptyLine)+ <|> try (do+ whiteSpace+ symbol "Warning:"+ text <- many anyChar+ return (WarningLine ("Warning:" ++ text)))+ <|> try (do+ text <- many anyChar+ eof+ return (OtherLine text))+ <?> "buildLineParser"++data BreakpointDescription = BreakpointDescription Int SrcSpan++breaksLineParser :: CharParser () BreakpointDescription+breaksLineParser = try (do+ char '['+ n <- int+ char ']'+ whiteSpace+ many (noneOf " ")+ whiteSpace+ span <- srcSpanParser+ return (BreakpointDescription n span))+ <?> "buildLineParser"++setBreakpointLineParser :: CharParser () BreakpointDescription+setBreakpointLineParser = try (do+ symbol "Breakpoint"+ whiteSpace+ n <- int+ whiteSpace+ symbol "activated"+ whiteSpace+ symbol "at"+ whiteSpace+ span <- srcSpanParser+ return (BreakpointDescription n span))+ <?> "setBreakpointLineParser"++lexer = P.makeTokenParser emptyDef+lexeme = P.lexeme lexer+whiteSpace = P.whiteSpace lexer+hexadecimal = P.hexadecimal lexer+symbol = P.symbol lexer+identifier = P.identifier lexer+colon = P.colon lexer+int = fmap fromInteger $ P.integer lexer++defaultLineLogger :: IDELog -> ToolOutput -> IDEM Int+defaultLineLogger log out = liftIO $ do+ case out of+ ToolInput line -> appendLog log (line ++ "\n") InputTag+ ToolOutput line -> appendLog log (line ++ "\n") LogTag+ ToolError line -> appendLog log (line ++ "\n") ErrorTag++logOutputLines :: (IDELog -> ToolOutput -> IDEM a) -> [ToolOutput] -> IDEM [a]+logOutputLines lineLogger output = do+ log :: IDELog <- getLog+ liftIO $ bringPaneToFront log+ results <- forM output $ lineLogger log+ liftIO $ appendLog log "----------------------------------\n" FrameTag+ sb <- getSBErrors+ liftIO $ statusbarPop sb 1+ liftIO $ statusbarPush sb 1 ""+ return results++logOutputLines_ :: (IDELog -> ToolOutput -> IDEM a) -> [ToolOutput] -> IDEAction+logOutputLines_ lineLogger output = do+ logOutputLines lineLogger output+ return ()++logOutput :: [ToolOutput] -> IDEM ()+logOutput output = do+ logOutputLines defaultLineLogger output+ return ()++logOutputForBuild :: Bool -> [ToolOutput] -> IDEAction+logOutputForBuild backgroundBuild output = do+ ideRef <- ask+ log <- getLog+ unless backgroundBuild $ liftIO $ bringPaneToFront log+ errs <- liftIO $ readAndShow output ideRef log False []+ setErrorList $ reverse errs+ triggerEventIDE (Sensitivity [(SensitivityError,not (null errs))])+ sb <- getSBErrors+ let errorNum = length (filter isError errs)+ let warnNum = length errs - errorNum+ liftIO $ statusbarPop sb 1+ liftIO $ statusbarPush sb 1 $show errorNum ++ " Errors, " ++ show warnNum ++ " Warnings"+ unless backgroundBuild nextError+ return ()+ where+ readAndShow :: [ToolOutput] -> IDERef -> IDELog -> Bool -> [LogRef] -> IO [LogRef]+ readAndShow [] _ log _ errs = do+ let errorNum = length (filter isError errs)+ let warnNum = length errs - errorNum+ case errs of+ [] -> appendLog log "----------------------------------\n" FrameTag+ _ -> appendLog log ("----- " ++ show errorNum ++ " errors -- "+ ++ show warnNum ++ " warnings -----\n") FrameTag+ return errs+ readAndShow (output:remainingOutput) ideR log inError errs = do+ case output of+ ToolError line -> do+ let parsed = parse buildLineParser "" line+ let nonErrorPrefixes = ["Linking ", "ar:", "ld:", "ld warning:"]+ tag <- case parsed of+ Right BuildLine -> return InfoTag+ Right (OtherLine text) | "Linking " `isPrefixOf` text -> do+ -- when backgroundBuild $ reflectIDE interruptProcess ideR+ postGUIAsync $ reflectIDE (do+ setErrorList $ reverse errs+ ) ideR+ return InfoTag+ Right (OtherLine text) | any (`isPrefixOf` text) nonErrorPrefixes -> do+ return InfoTag+ _ -> return ErrorTag+ lineNr <- appendLog log (line ++ "\n") tag+ case (parsed, errs) of+ (Left e,_) -> do+ sysMessage Normal (show e)+ readAndShow remainingOutput ideR log False errs+ (Right ne@(ErrorLine span str),_) ->+ readAndShow remainingOutput ideR log True ((LogRef span str (lineNr,lineNr) ErrorRef):errs)+ (Right (OtherLine str1),(LogRef span str (l1,l2) refType):tl) ->+ if inError+ then readAndShow remainingOutput ideR log True ((LogRef span+ (if null str+ then line+ else str ++ "\n" ++ line)+ (l1,lineNr) refType) : tl)+ else readAndShow remainingOutput ideR log False errs+ (Right (WarningLine str1),(LogRef span str (l1,l2) isError):tl) ->+ if inError+ then readAndShow remainingOutput ideR log True ((LogRef span+ (if null str+ then line+ else str ++ "\n" ++ line)+ (l1,lineNr) WarningRef) : tl)+ else readAndShow remainingOutput ideR log False errs+ otherwise -> readAndShow remainingOutput ideR log False errs+ ToolOutput line -> do+ appendLog log (line ++ "\n") LogTag+ readAndShow remainingOutput ideR log inError errs+ ToolInput line -> do+ appendLog log (line ++ "\n") InputTag+ readAndShow remainingOutput ideR log inError errs++logOutputForBreakpoints :: [ToolOutput] -> IDEAction+logOutputForBreakpoints output = do+ breaks <- logOutputLines (\log out -> do+ case out of+ ToolOutput line -> do+ logLineNumber <- liftIO $ appendLog log (line ++ "\n") LogTag+ case parse breaksLineParser "" line of+ Right (BreakpointDescription n span) ->+ return $ Just $ LogRef span line (logLineNumber, logLineNumber) BreakpointRef+ _ -> return Nothing+ _ -> do+ defaultLineLogger log out+ return Nothing) output+ setBreakpointList $ catMaybes breaks++logOutputForSetBreakpoint :: [ToolOutput] -> IDEAction+logOutputForSetBreakpoint output = do+ breaks <- logOutputLines (\log out -> do+ case out of+ ToolOutput line -> do+ logLineNumber <- liftIO $ appendLog log (line ++ "\n") LogTag+ case parse setBreakpointLineParser "" line of+ Right (BreakpointDescription n span) ->+ return $ Just $ LogRef span line (logLineNumber, logLineNumber) BreakpointRef+ _ -> return Nothing+ _ -> do+ defaultLineLogger log out+ return Nothing) output+ addLogRefs $ catMaybes breaks++logOutputForContext :: (String -> [SrcSpan]) -> [ToolOutput] -> IDEAction+logOutputForContext getContexts output = do+ refs <- fmap catMaybes $ logOutputLines (\log out -> do+ case out of+ ToolOutput line -> do+ logLineNumber <- liftIO $ appendLog log (line ++ "\n") LogTag+ let contexts = getContexts line+ if null contexts+ then return Nothing+ else return $ Just $ LogRef (last contexts) line (logLineNumber, logLineNumber) ContextRef+ _ -> do+ defaultLineLogger log out+ return Nothing) output+ unless (null refs) $ do+ addLogRefs [last refs]+ lastContext++logOutputForLiveContext :: [ToolOutput] -> IDEAction+logOutputForLiveContext = logOutputForContext getContexts+ where+ getContexts [] = []+ getContexts line@(x:xs) = case stripPrefix "Stopped at " line of+ Just rest -> case parse srcSpanParser "" rest of+ Right desc -> desc : getContexts xs+ _ -> getContexts xs+ _ -> getContexts xs++logOutputForHistoricContext :: [ToolOutput] -> IDEAction+logOutputForHistoricContext = logOutputForContext getContexts+ where+ getContexts line = case stripPrefix "Logged breakpoint at " line of+ Just rest -> case parse srcSpanParser "" rest of+ Right desc -> [desc]+ _ -> []+ _ -> []+
src/IDE/Menu.hs view
@@ -16,7 +16,7 @@ module IDE.Menu (- actions+ mkActions , menuDescription , makeMenu , quit@@ -25,6 +25,10 @@ , newIcons , setSensitivity , updateRecentEntries+, handleSpecialKeystrokes+, registerEvents+, instrumentWindow+, instrumentSecWindow ) where import Graphics.UI.Gtk@@ -42,6 +46,7 @@ import IDE.Pane.Preferences import IDE.Pane.PackageFlags import IDE.Pane.PackageEditor+import IDE.Pane.Errors import IDE.Package import IDE.Pane.Log import IDE.SaveSession@@ -53,16 +58,34 @@ import IDE.Pane.References import Paths_leksah import IDE.GUIHistory-import IDE.Metainfo.Provider (rebuildLibInfo,rebuildActiveInfo)-import IDE.Pane.Info (showInfo)+import IDE.Metainfo.Provider+ (infoForActivePackage, rebuildLibInfo, rebuildActiveInfo)+import IDE.Pane.Info (setSymbol, showInfo) import IDE.NotebookFlipper import IDE.ImportTool (addAllImports)-+import IDE.LogRef+import IDE.Debug+import System.Directory (doesFileExist)+import qualified Graphics.UI.Gtk.Gdk.Events as GdkEvents+import Graphics.UI.Gtk.Gdk.Events+ (Modifier(..),+ Event(..))+import Graphics.UI.Gtk.Gdk.Enums (Modifier(..))+import qualified Data.Map as Map (lookup)+import Data.List (sort)+import Control.Event (registerEvent)+import Paths_leksah+import IDE.Pane.Breakpoints+ (showBreakpointList, fillBreakpointList, selectBreak)+import Debug.Trace (trace)+import IDE.Pane.Variables (showVariables, fillVariablesList)+import IDE.Pane.Trace (showTrace,fillTraceList)+import IDE.Group.Debugger(showDebugger) -- -- | The Actions known to the system (they can be activated by keystrokes or menus) ---actions :: [ActionDescr IDERef]-actions =+mkActions :: [ActionDescr IDERef]+mkActions = [AD "File" "_File" Nothing Nothing (return ()) [] False ,AD "FileNew" "_New" Nothing (Just "gtk-new") fileNew [] False@@ -76,11 +99,11 @@ ,AD "FileSaveAs" "Save _As" Nothing (Just "gtk-save-as") (do fileSave True; return ()) [] False ,AD "FileSaveAll" "Save A_ll" Nothing Nothing- (do fileSaveAll; return ()) [] False+ (do fileSaveAll (\ b -> return (bufferName b /= "_Eval.hs")); return ()) [] False ,AD "FileClose" "_Close" Nothing (Just "gtk-close") (do fileClose; return ()) [] False ,AD "FileCloseAll" "Close All" Nothing Nothing- (do fileCloseAll; return ()) [] False+ (do fileCloseAll (\ b -> return (bufferName b /= "_Eval.hs")); return ()) [] False ,AD "FileCloseAllButPackage" "Close All But Package" Nothing Nothing (do fileCloseAllButPackage; return ()) [] False ,AD "Quit" "_Quit" Nothing (Just "gtk-quit")@@ -91,11 +114,11 @@ editUndo [] False ,AD "EditRedo" "_Redo" Nothing (Just "gtk-redo") editRedo [] False- ,AD "EditCut" "Cu_t" Nothing Nothing{--Just "gtk-cut"--}+ ,AD "EditCut" "Cu_t" Nothing (Just "gtk-cut") editCut [] {--Just "<control>X"--} False- ,AD "EditCopy" "_Copy" Nothing Nothing{--Just "gtk-copy"--}+ ,AD "EditCopy" "_Copy" Nothing (Just "gtk-copy") editCopy [] {--Just "<control>C"--} False- ,AD "EditPaste" "_Paste" Nothing Nothing{--Just "gtk-paste"--}+ ,AD "EditPaste" "_Paste" Nothing (Just "gtk-paste") editPaste [] {--Just "<control>V"--} False ,AD "EditDelete" "_Delete" Nothing (Just "gtk-delete") editDelete [] False@@ -129,8 +152,6 @@ ,AD "EditAlignTypeSig" "Align _::" Nothing Nothing (align ':') [] False - ,AD "EditCandy" "_To Candy" Nothing Nothing- editCandy [] True ,AD "Package" "_Package" Nothing Nothing (return ()) [] False ,AD "NewPackage" "_New Package" Nothing Nothing@@ -177,8 +198,91 @@ ,AD "OpenDocPackage" "_Open Doc" Nothing Nothing packageOpenDoc [] False + ,AD "Debug" "_Debug" Nothing Nothing (return ()) [] False+ ,AD "StartDebugger" "_Start Debugger" (Just "Starts using the GHCi debugger for build and run") Nothing+ debugStart [] False+ ,AD "QuitDebugger" "_Quit Debugger" (Just "Quit the GHCi debugger if it is running") Nothing+ debugQuit [] False+ ,AD "ExecuteSelection" "_Execute Selection" (Just "Sends the selected text to the debugger") Nothing+ debugExecuteSelection [] False+ ,AD "ShowErrorsList" "Show Errors" Nothing Nothing+ showErrors [] False+ ,AD "ShowBreakpointsList" "Show Breakpoints List" Nothing Nothing+ (trace "1" showBreakpointList) [] False+ ,AD "ShowVariablesList" "Show Variables List" Nothing Nothing+ showVariables [] False+ ,AD "ShowTracesList" "Show Traces List" Nothing Nothing+ showTrace [] False+ ,AD "ShowEval" "Show Eval" Nothing Nothing+ {--showTrace--} undefined [] False+ ,AD "ShowDebugger" "Show Debugger" Nothing Nothing+ showDebugger [] False++ ,AD "DebugSetBreakpoint" "Set Breakpoint" (Just "Set a breakpoint on the selected name or current line") Nothing+ debugSetBreakpoint [] False+ ,AD "ShowNextBreakpoint" "Show Next Breakpoint" (Just "Show the next breakpoint") Nothing+ nextBreakpoint [] False+ ,AD "ShowPreviousBreakpoint" "Show Previous Breakpoint" (Just "Show the previous breakpoint") Nothing+ previousBreakpoint [] False+ ,AD "DebugDeleteAllBreakpoints" "Delete All Breakpoints" (Just "") Nothing+ debugDeleteAllBreakpoints [] False++ ,AD "DebugContinue" "Continue" (Just "Resume after a breakpoint") (Just "ide_continue")+ debugContinue [] False+ ,AD "DebugAbandon" "Abandon" (Just "At a breakpoint, abandon current computation") Nothing+ debugAbandon [] False+ ,AD "DebugStop" "Stop" (Just "Interrupt the running operation.") Nothing+ debugStop [] False++ ,AD "DebugStep" "Step" (Just "Single-step after stopping at a breakpoint") (Just "ide_step")+ debugStep [] False+ ,AD "DebugStepExpression" "Step Expression" (Just "Single-step into selected expression") Nothing+ debugStepExpression [] False+ ,AD "DebugStepLocal" "Step Local" (Just "Single-step within the current top-level binding") (Just "ide_local")+ debugStepLocal [] False+ ,AD "DebugStepModule" "Step Module" (Just "Single-step restricted to the current module") (Just "ide_module")+ debugStepModule [] False++ ,AD "DebugTrace" "Trace" (Just "Trace after stopping at a breakpoint") Nothing+ debugTrace [] False+ ,AD "DebugTraceExpression" "Trace Expression" (Just "Evaluate the selected expression with tracing on") Nothing+ debugTraceExpression [] False+ ,AD "DebugHistory" "History" (Just "After 'Trace', show the execution history") Nothing+ debugHistory [] False+ ,AD "DebugBack" "Back" (Just "Go back in the history (after 'Trace')") Nothing+ debugBack [] False+ ,AD "DebugForward" "Forward" (Just "Go forward in the history (after 'Back')") Nothing+ debugForward [] False++ ,AD "DebugForce" "Force" (Just "Print the selected expression, forcing unevaluated parts") Nothing+ debugForce [] False+ ,AD "DebugPrint" "Print" (Just "Prints a value without forcing its computation") Nothing+ debugPrint [] False+ ,AD "DebugSimplePrint" "SimplePrint" (Just "Simplifed version of Print") Nothing+ debugSimplePrint [] False++ ,AD "ShowBindings" "Show Bin_dings" (Just "Show the current bindings") Nothing+ debugShowBindings [] False+ ,AD "ShowBreakpoints" "Show _Breakpoints" (Just "Show the active breakpoints") Nothing+ debugShowBreakpoints [] False+ ,AD "ShowContext" "Show _Context" (Just "Show the breakpoint context") Nothing+ debugShowContext [] False+ ,AD "ShowLoadedModules" "Show Loaded _Modules" (Just "Show the currently loaded modules") Nothing+ debugShowModules [] False+ ,AD "ShowPackages" "Show _Packages" (Just "Show the currently active packages") Nothing+ debugShowPackages [] False+ ,AD "ShowLanguages" "Show _Languages" (Just "Show the currently active language") Nothing+ debugShowLanguages [] False++ ,AD "DebugInformation" "Information" (Just "Display information about the selected name(s)") Nothing+ debugInformation [] False+ ,AD "DebugKind" "Kind" (Just "Show the kind of the selected type") Nothing+ debugKind [] False+ ,AD "DebugType" "Type" (Just "Show the type of the selected expression") Nothing+ debugType [] False+ ,AD "Metadata" "_Metadata" Nothing Nothing (return ()) [] False- ,AD "UpdateMetadataCurrent" "_Update Project" Nothing Nothing+ ,AD "UpdateMetadataCurrent" "_Update Project" (Just "Updates metadata for the current project") (Just "ide_rebuild_meta") rebuildActiveInfo [] False ,AD "UpdateMetadataLib" "_Update Lib" Nothing Nothing rebuildLibInfo [] False@@ -216,6 +320,10 @@ viewSplitVertical [] False ,AD "ViewCollapse" "_Collapse" Nothing Nothing viewCollapse [] False+ ,AD "ViewNest" "_Group" Nothing Nothing+ (viewNewGroup) [] False+ ,AD "ViewDetach" "_Detach" Nothing Nothing+ viewDetachInstrumented [] False ,AD "ViewTabsLeft" "Tabs Left" Nothing Nothing (viewTabsPos PosLeft) [] False@@ -249,19 +357,27 @@ ,AD "ToggleToolbar" "Toggle Toolbar" Nothing Nothing toggleToolbar [] False - ,AD "Help" "_Help" Nothing Nothing (return ()) [] False+ ,AD "Configuration" "_Configuration" Nothing Nothing (return ()) [] False+ ,AD "EditCandy" "_To Candy" Nothing Nothing+ editCandy [] True ,AD "PrefsEdit" "_Edit Prefs" Nothing Nothing editPrefs [] False++ ,AD "Help" "_Help" Nothing Nothing (return ()) [] False ,AD "HelpDebug" "Debug" Nothing Nothing (do pack <- readIDE activePack ideMessage Normal (show pack)) [] False -- ,AD "HelpDebug2" "Debug2" (Just "<Ctrl>d") Nothing dbgInstalledPackageInfo [] False- ,AD "HelpAbout" "About" Nothing (Just "gtk-about") aboutDialog [] False+ ,AD "HelpManual" "Manual" Nothing Nothing (openBrowser "http://leksah.org/leksah_manual.pdf") [] False+ ,AD "HelpHomepage" "Homepage" Nothing Nothing (openBrowser "http://leksah.org") [] False+ ,AD "HelpAbout" "About" Nothing (Just "gtk-about") (liftIO aboutDialog) [] False ,AD "BackgroundBuildToggled" "_BackgroundBuild" (Just "Build in the background and report errors") (Just "ide_build") backgroundBuildToggled [] True ,AD "BackgroundLinkToggled" "_BackgroundLink" (Just "Link in the background") (Just "ide_link")- backgroundLinkToggled [] True]+ backgroundLinkToggled [] True+ ,AD "DebugToggled" "_Debug" (Just "Use GHCi debugger to build and run") (Just "ide_debug")+ debugToggled [] True] -- -- | The menu description in XML Syntax as defined by GTK@@ -281,9 +397,11 @@ reifyIDE (\ ideR -> do recentFilesMenu <- menuNew mapM_ (\s -> do- mi <- menuItemNewWithLabel s- mi `onActivateLeaf` (reflectIDE (fileOpenThis s) ideR)- menuShellAppend recentFilesMenu mi) recentFiles'+ fe <- doesFileExist s+ when fe $ do+ mi <- menuItemNewWithLabel s+ mi `onActivateLeaf` (reflectIDE (fileOpenThis s) ideR)+ menuShellAppend recentFilesMenu mi) recentFiles' oldSubmenu <- menuItemGetSubmenu recentFilesItem when (isJust oldSubmenu) $ do widgetHideAll (fromJust oldSubmenu)@@ -292,9 +410,11 @@ widgetShowAll recentFilesMenu recentPackagesMenu <- menuNew mapM_ (\s -> do- mi <- menuItemNewWithLabel s- mi `onActivateLeaf` (reflectIDE (packageOpenThis (Just s) >> return ()) ideR)- menuShellAppend recentPackagesMenu mi) recentPackages'+ fe <- doesFileExist s+ when fe $ 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)@@ -306,18 +426,13 @@ -- -- | Building the Menu ---makeMenu :: UIManager -> [ActionDescr IDERef] -> String -> IDEM (AccelGroup, [Widget])+makeMenu :: UIManager -> [ActionDescr IDERef] -> String -> IDEAction makeMenu uiManager actions menuDescription = reifyIDE (\ideR -> do actionGroupGlobal <- actionGroupNew "global" mapM_ (actm ideR actionGroupGlobal) actions uiManagerInsertActionGroup uiManager actionGroupGlobal 1 uiManagerAddUiFromString uiManager menuDescription- accGroup <- uiManagerGetAccelGroup uiManager- mbWidgets <- mapM (uiManagerGetWidget uiManager) ["ui/menubar","ui/toolbar"]- let widgets = map (\mb -> case mb of- Just it -> it- Nothing -> throwIDE "Menu>>makeMenu: failed to build menu") mbWidgets- return (accGroup,widgets))+ return ()) where actm ideR ag (AD name label tooltip stockId ideAction accs isToggle) = do let (acc,accString) = if null accs@@ -340,34 +455,105 @@ liftIO $statusbarPush sb 1 $accStr return ()) ideR) +getMenuAndToolbars :: UIManager -> IO (AccelGroup, MenuBar, Toolbar)+getMenuAndToolbars uiManager = do+ accGroup <- uiManagerGetAccelGroup uiManager+ mbMenu <- uiManagerGetWidget uiManager "/ui/menubar"+ let menu = case mbMenu of+ Just it -> castToMenuBar it+ Nothing -> throwIDE "Menu>>makeMenu: failed to create menubar"+ mbToolbar <- uiManagerGetWidget uiManager "/ui/toolbar"+ let toolbar = case mbToolbar of+ Just it -> castToToolbar it+ Nothing -> throwIDE "Menu>>makeMenu: failed to create toolbar"+ toolbarSetIconSize toolbar IconSizeSmallToolbar+ toolbarSetStyle toolbar ToolbarIcons+ widgetSetSizeRequest toolbar 700 (-1)+ return (accGroup,menu,toolbar)++textPopupMenu :: IDERef -> Menu -> IO ()+textPopupMenu ideR menu = do+ items <- containerGetChildren menu+ mi1 <- menuItemNewWithLabel "Eval"+ mi1 `onActivateLeaf` (reflectIDE debugExecuteSelection ideR)+ menuShellAppend menu mi1+ mi11 <- menuItemNewWithLabel "Eval & Insert"+ mi11 `onActivateLeaf` (reflectIDE debugExecuteAndShowSelection ideR)+ menuShellAppend menu mi11+ mi12 <- menuItemNewWithLabel "Step"+ mi12 `onActivateLeaf` (reflectIDE debugStepExpression ideR)+ menuShellAppend menu mi12+ mi13 <- menuItemNewWithLabel "Trace"+ mi13 `onActivateLeaf` (reflectIDE debugTraceExpression ideR)+ menuShellAppend menu mi13+ mi16 <- menuItemNewWithLabel "Set Breakpoint"+ mi16 `onActivateLeaf` (reflectIDE debugSetBreakpoint ideR)+ menuShellAppend menu mi16+ sep1 <- separatorMenuItemNew+ menuShellAppend menu sep1+ mi14 <- menuItemNewWithLabel "Type"+ mi14 `onActivateLeaf` (reflectIDE debugType ideR)+ menuShellAppend menu mi14+ mi141 <- menuItemNewWithLabel "Info"+ mi141 `onActivateLeaf` (reflectIDE debugInformation ideR)+ menuShellAppend menu mi141+ mi15 <- menuItemNewWithLabel "Kind"+ mi15 `onActivateLeaf` (reflectIDE debugKind ideR)+ menuShellAppend menu mi15+ sep2 <- separatorMenuItemNew+ menuShellAppend menu sep2+ mi2 <- menuItemNewWithLabel "Find (text)"+ mi2 `onActivateLeaf` (reflectIDE (editFindInc Initial) ideR)+ menuShellAppend menu mi2+ mi3 <- menuItemNewWithLabel "Search (metadata)"+ mi3 `onActivateLeaf` (reflectIDE (do+ mbtext <- selectedText+ case mbtext of+ Just t -> searchMetaGUI t+ Nothing -> ideMessage Normal "Select a text first") ideR)+ menuShellAppend menu mi3+ let interpretingEntries = [castToWidget mi16]+ let interpretingSelEntries = [castToWidget mi1, castToWidget mi11, castToWidget mi12,+ castToWidget mi13, castToWidget mi14, castToWidget mi141,+ castToWidget mi15]+ let otherEntries = [castToWidget mi2, castToWidget mi3]+ isInterpreting' <- (reflectIDE isInterpreting ideR)+ selected <- (reflectIDE selectedText ideR)+ unless isInterpreting'+ $ mapM_ (\w -> widgetSetSensitive w False) (interpretingEntries ++ interpretingSelEntries)+ unless (isJust selected)+ $ mapM_ (\w -> widgetSetSensitive w False) (otherEntries ++ interpretingSelEntries)+ mapM_ widgetShow interpretingEntries+ mapM_ widgetShow interpretingSelEntries+ mapM_ widgetShow (castToWidget sep1 : castToWidget sep2 : otherEntries)+ mapM_ widgetHide $ take 2 (reverse items)+ -- | Quit ide--- ### make reasonable--- quit :: IDEAction quit = do- modifyIDE_ (\ide -> return (ide{currentState = IsShuttingDown}))+ modifyIDE_ (\ide -> ide{currentState = IsShuttingDown}) saveSession :: IDEAction- b <- fileCloseAll+ b <- fileCloseAll (\_ -> return True) if b then liftIO mainQuit- else modifyIDE_ (\ide -> return (ide{currentState = IsRunning}))+ else modifyIDE_ (\ide -> ide{currentState = IsRunning}) -- -- | Show the about dialog ---aboutDialog :: IDEAction-aboutDialog = liftIO $ do+aboutDialog :: IO ()+aboutDialog = do d <- aboutDialogNew aboutDialogSetName d "Leksah" aboutDialogSetVersion d (showVersion version)- aboutDialogSetCopyright d "Copyright 2007-2009 Jürgen Nicklisch-Franken"+ aboutDialogSetCopyright d "Copyright 2007-2009 Jürgen Nicklisch-Franken, Hamish Mackenzie" aboutDialogSetComments d $ "An integrated development environement (IDE) for the " ++ "programming language Haskell and the Glasgow Haskell Compiler" dd <- getDataDir license <- catch (readFile $ dd </> "LICENSE") (\ (_ :: SomeException) -> return "") aboutDialogSetLicense d $ Just license aboutDialogSetWebsite d "http://leksah.org/"- aboutDialogSetAuthors d ["Jürgen Nicklisch-Franken (Jutaro)","Hamish Mackenzie"]+ aboutDialogSetAuthors d ["Jürgen Nicklisch-Franken","Hamish Mackenzie"] dialogRun d widgetDestroy d return ()@@ -428,10 +614,10 @@ iconFactory <- iconFactoryNew dataDir <- getDataDir mapM_ (loadIcon dataDir iconFactory) ["ide_class","ide_configure","ide_data","ide_error_next",- "ide_error_prev","ide_field","ide_function","ide_instance", "ide_konstructor","ide_make",+ "ide_error_prev","ide_function","ide_instance", "ide_konstructor","ide_make", "ide_method","ide_newtype","ide_other","ide_rule","ide_run","ide_slot",- "ide_source","ide_type","leksah", "ide_reexported", "ide_clean", "ide_link", "ide_build"- ]+ "ide_source","ide_type","leksah", "ide_reexported", "ide_clean", "ide_link", "ide_build",+ "ide_debug", "ide_step", "ide_local", "ide_module", "ide_continue", "ide_rebuild_meta"] iconFactoryAddDefault iconFactory) (\(e :: SomeException) -> getDataDir >>= \dataDir -> throwIDE ("Can't load icons from " ++ dataDir)) where@@ -457,7 +643,12 @@ getActionsFor SensitivityError = getActionsFor' ["NextError", "PreviousError"] getActionsFor SensitivityEditor = getActionsFor' ["EditUndo", "EditRedo", "EditGotoLine" ,"EditComment", "EditUncomment", "EditShiftLeft", "EditShiftRight"]-+getActionsFor SensitivityInterpreting = getActionsFor' ["QuitDebugger" , "ExecuteSelection",+ "DebugSetBreakpoint", "ShowNextBreakpoint", "ShowPreviousBreakpoint", "DebugDeleteAllBreakpoints",+ "DebugContinue", "DebugAbandon", "DebugStop", "DebugStep", "DebugStepExpression", "DebugStepLocal",+ "DebugStepModule", "DebugTrace", "DebugTraceExpression", "DebugHistory", "DebugBack", "DebugForward",+ "DebugForce", "DebugPrint", "DebugSimplePrint", "ShowBindings", "ShowBreakpoints", "ShowContext",+ "ShowLoadedModules", "ShowPackages", "ShowLanguages", "DebugInformation", "DebugKind", "DebugType"] getActionsFor' :: [String] -> IDEM[Action] getActionsFor' l = do@@ -465,11 +656,172 @@ return (catMaybes r) where getActionFor string = do- uiManager' <- readIDE uiManager+ uiManager' <- getUiManager actionGroups <- liftIO $ uiManagerGetActionGroups uiManager' res <- liftIO $ actionGroupGetAction (head actionGroups) string when (isNothing res) $ ideMessage Normal $ "Can't find UI Action " ++ string return res +viewDetachInstrumented :: IDEAction+viewDetachInstrumented = do+ mbPair <- viewDetach+ case mbPair of+ Nothing -> return ()+ Just (win,wid) -> do+ instrumentSecWindow win+ liftIO $ widgetShowAll win++instrumentWindow :: Window -> Prefs -> Widget -> IDEAction+instrumentWindow win prefs topWidget = do+ -- sets the icon+ ideR <- ask+ uiManager' <- getUiManager+ liftIO $ do+ dataDir <- getDataDir+ let iconPath = dataDir </> "data" </> "leksah.png"+ iconExists <- doesFileExist iconPath+ when iconExists $+ windowSetIconFromFile win iconPath+ vb <- vBoxNew False 1 -- Top-level vbox+ widgetSetName vb "topBox"+ (acc,menu,toolbar) <- getMenuAndToolbars uiManager'+ boxPackStart vb menu PackNatural 0+ boxPackStart vb toolbar PackNatural 0+ boxPackStart vb topWidget PackGrow 0+ findbar <- reflectIDE (do+ modifyIDE_ (\ide -> ide{toolbar = (True,Just toolbar)})+ constructFindReplace ) ideR+ boxPackStart vb findbar PackNatural 0+ statusBar <- buildStatusbar ideR+ boxPackEnd vb statusBar PackNatural 0+ win `onKeyPress` (\ e -> reflectIDE (handleSpecialKeystrokes e) ideR)+ windowAddAccelGroup win acc+ containerAdd win vb+ reflectIDE (do+ setCandyState (isJust (sourceCandy prefs))+ setBackgroundBuildToggled (backgroundBuild prefs)+ setBackgroundLinkToggled (backgroundLink prefs)) ideR++instrumentSecWindow :: Window -> IDEAction+instrumentSecWindow win = do+ ideR <- ask+ uiManager' <- getUiManager+ liftIO $ do+ dataDir <- getDataDir+ let iconPath = dataDir </> "data" </> "leksah.png"+ iconExists <- doesFileExist iconPath+ when iconExists $+ windowSetIconFromFile win iconPath++ (acc,_,_) <- getMenuAndToolbars uiManager'+ windowAddAccelGroup win acc+ win `onKeyPress` (\ e -> reflectIDE (handleSpecialKeystrokes e) ideR)+ return ()++--+-- | Callback function for onKeyPress of the main window, so 'preprocess' any key+--+handleSpecialKeystrokes :: GdkEvents.Event -> IDEM Bool+handleSpecialKeystrokes (Key { eventKeyName = name, eventModifier = mods,+ eventKeyVal = keyVal, eventKeyChar = mbChar}) = do+ sb <- getSBSpecialKeys+ prefs' <- readIDE prefs+ case (name, mods) of+ (tab, [Control]) | (tab == "Tab" || tab == "ISO_Left_Tab")+ && useCtrlTabFlipping prefs' -> do+ flipDown+ return True+ (tab, [Shift, Control]) | (tab == "Tab" || tab == "ISO_Left_Tab")+ && useCtrlTabFlipping prefs' -> do+ flipUp+ return True+ _ -> do+ bs <- getCandyState+ when bs (editKeystrokeCandy mbChar)+ sk <- readIDE specialKey+ sks <- readIDE specialKeys+ return True+ case sk of+ Nothing ->+ case Map.lookup (keyVal,sort mods) sks of+ Nothing -> do+ liftIO $statusbarPop sb 1+ liftIO $statusbarPush sb 1 ""+ return False+ Just map -> do+ let sym = printMods mods ++ name+ liftIO $statusbarPop sb 1+ liftIO $statusbarPush sb 1 sym+ modifyIDE_ (\ide -> ide{specialKey = Just (map,sym)})+ return True+ Just (map,sym) -> do+ case Map.lookup (keyVal,sort mods) map of+ Nothing -> do+ liftIO $statusbarPop sb 1+ liftIO $statusbarPush sb 1 $ sym ++ printMods mods ++ name ++ "?"+ return ()+ Just (AD actname _ _ _ ideAction _ _) -> do+ liftIO $statusbarPop sb 1+ liftIO $statusbarPush sb 1+ $ sym ++ " " ++ printMods mods ++ name ++ "=" ++ actname+ ideAction+ modifyIDE_ (\ide -> ide{specialKey = Nothing})+ return True+ where+ printMods :: [Modifier] -> String+ printMods [] = ""+ printMods (m:r) = show m ++ printMods r+handleSpecialKeystrokes _ = return True++--+-- | Register handlers for IDE events+--+registerEvents :: IDEAction+registerEvents = do+ stRef <- ask+ registerEvent stRef "LogMessage"+ (Left (\e@(LogMessage s t) -> getLog >>= \(log :: IDELog) -> liftIO $ appendLog log s t+ >> return e))+ registerEvent stRef "SelectInfo"+ (Left (\ e@(SelectInfo str) -> setSymbol str >> return e))+ registerEvent stRef "SelectIdent"+ (Left (\ e@(SelectIdent id) -> selectIdentifier id >> return e))+ registerEvent stRef "CurrentInfo"+ (Left (\ CurrentInfo -> reloadKeepSelection >> return CurrentInfo))+ registerEvent stRef "ActivePack"+ (Left (\ ActivePack -> (infoForActivePackage :: IDEAction) >> return ActivePack))+ registerEvent stRef "RecordHistory"+ (Left (\ rh@(RecordHistory h) -> recordHistory h >> return rh))+ registerEvent stRef "Sensitivity"+ (Left (\ s@(Sensitivity h) -> setSensitivity h >> return s))+ registerEvent stRef "DescrChoice"+ (Left (\ e@(DescrChoice descrs) -> setChoices descrs >> return e))+ registerEvent stRef "SearchMeta"+ (Left (\ e@(SearchMeta string) -> searchMetaGUI string >> return e))+ registerEvent stRef "LoadSession"+ (Left (\ e@(LoadSession fp) -> loadSession fp >> return e))+ registerEvent stRef "SaveSession"+ (Left (\ e@(SaveSession fp) -> saveSessionAs fp >> return e))+ registerEvent stRef "UpdateRecent"+ (Left (\ e@UpdateRecent -> updateRecentEntries >> return e))+ registerEvent stRef "VariablesChanged"+ (Left (\ e@VariablesChanged -> fillVariablesList >> return e))+ registerEvent stRef "ErrorChanged"+ (Left (\ e@ErrorChanged -> postAsyncIDE fillErrorList >> return e))+ registerEvent stRef "CurrentErrorChanged"+ (Left (\ e@(CurrentErrorChanged mbLogRef) -> postAsyncIDE (do+ selectRef mbLogRef+ selectError mbLogRef) >> return e))+ registerEvent stRef "BreakpointChanged"+ (Left (\ e@BreakpointChanged -> postAsyncIDE fillBreakpointList >> return e))+ registerEvent stRef "CurrentBreakChanged"+ (Left (\ e@(CurrentBreakChanged mbLogRef) -> postAsyncIDE (do+ selectRef mbLogRef+ selectBreak mbLogRef) >> return e))+ registerEvent stRef "TraceChanged"+ (Left (\ e@TraceChanged -> fillTraceList >> return e))+ registerEvent stRef "GetTextPopup"+ (Left (\ e@(GetTextPopup _) -> return (GetTextPopup (Just textPopupMenu))))+ return ()
src/IDE/Metainfo/GHCUtils.hs view
@@ -77,7 +77,7 @@ then [maximumBy (\a b -> compare (pkgVersion a) (pkgVersion b)) filtered] else filtered -parseHeader :: FilePath -> String -> IDEM (Maybe [LImportDecl RdrName])+parseHeader :: FilePath -> String -> IDEM (Maybe (HsModule RdrName)) parseHeader fp str = do activePack' <- readIDE activePack case activePack' of@@ -98,7 +98,7 @@ stringBuffer <- hGetStringBuffer fp parseResult <- myParseModuleHeader dynFlags fp (Just stringBuffer) case parseResult of- Right (L _ mod) -> return (Just (hsmodImports mod))+ Right (L _ mod) -> return (Just mod) Left errMsg -> do sysMessage Normal $ "Failed to parse " ++ fp printBagOfErrors defaultDynFlags (unitBag errMsg)
src/IDE/Metainfo/InterfaceCollector.hs view
@@ -344,7 +344,7 @@ in [descr{details' = ClassDescr{super = superclasses, methods = classOpsID}}] (IfaceSyn _ _ _ _ _ )- -> [descr]+ -> [descr{details' = TypeDescr}] (IfaceForeign _ _) -> [descr]
src/IDE/Metainfo/Provider.hs view
@@ -19,11 +19,11 @@ , getIdentifiersStartingWith , getCompletionOptions , getDescription+, getActivePackageDescr , initInfo , updateAccessibleInfo , infoForActivePackage-, mayRebuildInBackground , rebuildActiveInfo , searchMeta , rebuildLibInfo@@ -47,9 +47,6 @@ import Data.Map (Map) import qualified Data.ByteString.Char8 as BS import qualified Data.ByteString.Lazy as BSL-import System.Process (ProcessHandle(..),getProcessExitCode)-import System.Glib.MainLoop(timeoutAddFull,priorityDefaultIdle)-import Control.Monad.Reader(ask) import Distribution.Version import Distribution.ModuleName import GHC (runGhc)@@ -58,7 +55,6 @@ import IDE.FileUtils import IDE.Core.State import IDE.Metainfo.InterfaceCollector-import Control.Event import Data.Char (toLower,isUpper,toUpper,isLower) import Text.Regex.Posix import System.IO.Unsafe (unsafePerformIO)@@ -67,6 +63,17 @@ import Data.Binary.Shared (decodeSer) import System.Mem (performGC) +getActivePackageDescr :: IDEM (Maybe PackageDescr)+getActivePackageDescr = do+ mbActive <- readIDE activePack+ case mbActive of+ Nothing -> return Nothing+ Just pack -> do+ currentInfo' <- readIDE currentInfo+ case currentInfo' of+ Nothing -> return Nothing+ Just ((map,_),(_,_)) -> return (packageId pack `Map.lookup` map)+ -- -- | Lookup of an identifier description --@@ -226,16 +233,15 @@ $ map fromJust $ filter isJust packageList liftIO performGC- modifyIDE_ (\ide -> return (ide{accessibleInfo = (Just scope)}))+ modifyIDE_ (\ide -> ide{accessibleInfo = (Just scope)}) -- -- | Clears the current info, not the world infos -- clearCurrentInfo :: IDEAction clearCurrentInfo = do- modifyIDE_ (\ide -> return (ide{currentInfo = Nothing}))- ideR <- ask- triggerEvent ideR CurrentInfo+ modifyIDE_ (\ide -> ide{currentInfo = Nothing})+ triggerEventIDE CurrentInfo return () --@@ -246,7 +252,7 @@ activePack <- readIDE activePack case activePack of Nothing -> do- modifyIDE_ (\ide -> return (ide{currentInfo = Nothing}))+ modifyIDE_ (\ide -> ide{currentInfo = Nothing}) Just pack -> do let depends' = depends pack fp <- inGhc $ findFittingPackages depends'@@ -254,52 +260,25 @@ case mbActive of Nothing -> do -- no meta info available- modifyIDE_ (\ide -> return (ide{currentInfo = Nothing}))+ modifyIDE_ (\ide -> ide{currentInfo = Nothing}) Just active -> do accessibleInfo' <- readIDE accessibleInfo case accessibleInfo' of- Nothing -> modifyIDE_ (\ide -> return (ide{currentInfo = Nothing}))+ Nothing -> modifyIDE_ (\ide -> ide{currentInfo = Nothing}) Just (pdmap,_) -> do let packageList = map (\ pin -> pin `Map.lookup` pdmap) fp let scope = foldr buildScope (Map.empty,Map.empty) $ map fromJust $ filter isJust packageList- modifyIDE_ (\ide -> return (ide{currentInfo = Just (active, scope)}))- ideR <- ask- triggerEvent ideR CurrentInfo+ modifyIDE_ (\ide -> ide{currentInfo = Just (active, scope)})+ triggerEventIDE CurrentInfo return () ----- | Builds the current info for the activePackage in the background--- If a process handle is given, it waits for this process to finish before building+-- | Builds the current info for the activePackage ---mayRebuildInBackground :: Maybe ProcessHandle -> IDEAction-mayRebuildInBackground mbHandle = reifyIDE $ \ ideR ->- let- myRebuild :: IO Bool- myRebuild =- case mbHandle of- Just hdl -> do- mbExitCode <- getProcessExitCode hdl- case mbExitCode of- --process not finished, wait for next call- Nothing -> return True- Just _ -> doIt- Nothing -> doIt- doIt :: IO Bool- doIt = do- reflectIDE (do- errs <- readIDE errors- when (length (filter isError errs) == 0) $ do- ideMessage Normal "Update meta info for active package"- setInfo buildActiveInfo) ideR- return False- in do- timeoutAddFull myRebuild priorityDefaultIdle 500- return ()- rebuildActiveInfo :: IDEAction rebuildActiveInfo = setInfo buildActiveInfo @@ -316,9 +295,8 @@ case newActive of Nothing -> return () Just newActive -> do- modifyIDE_ (\ide -> return (ide{currentInfo = Just (newActive, scope)}))- ideR <- ask- triggerEvent ideR CurrentInfo+ modifyIDE_ (\ide -> ide{currentInfo = Just (newActive, scope)})+ triggerEventIDE CurrentInfo return () --@@ -406,7 +384,7 @@ let psamp3 = foldr (\e m -> Map.delete e m) psmap trashPackages let scope = foldr buildScope (Map.empty,Map.empty) (Map.elems psamp3)- modifyIDE_ (\ide -> return (ide{accessibleInfo = Just scope}))+ modifyIDE_ (\ide -> ide{accessibleInfo = Just scope}) -- -- | Loads the infos for the given packages
src/IDE/Metainfo/SourceCollector.hs view
@@ -143,11 +143,11 @@ return(moduleDescr : moduleDescrs, failureCount+1) Just fp -> do session <- getSession- (_,fp) <- preprocess session (fp,Nothing)+ (_,fp') <- preprocess session (fp,Nothing) dynFlags <- getSessionDynFlags liftIO $ do- stringBuffer <- hGetStringBuffer fp- parseResult <- myParseModule dynFlags fp (Just stringBuffer)+ stringBuffer <- hGetStringBuffer fp'+ parseResult <- myParseModule dynFlags fp' (Just stringBuffer) let newModD = moduleDescr{mbSourcePathMD = mbfp} case parseResult of Right (L _ (HsModule _ _ _ decls _ _ _ )) -> do@@ -250,6 +250,7 @@ mbItems = Map.lookup name st (mbItem,nst)= case mbItems of Nothing -> (Nothing,st)+ Just [i] -> (Just i, Map.delete name st) Just list -> case filter (\i -> matches i types insts) list of
src/IDE/NotebookFlipper.hs view
@@ -24,6 +24,7 @@ import Graphics.UI.Gtk.Gdk.Events (Event(..)) import Control.Monad (when) import Graphics.UI.Frame.Panes (makeActive)+import IDE.Pane.SourceBuffer(recentSourceBuffers) flipDown :: IDEAction flipDown = do@@ -78,8 +79,8 @@ -- | Initiate Filpper , If True moves down, if false up initFlipper :: Bool -> IDEAction initFlipper direction = do- mainWindow <- readIDE window- recentPanes' <- readIDE recentPanes+ mainWindow <- getMainWindow+ recentPanes' <- recentSourceBuffers tree' <- reifyIDE $ \ideR -> do window <- windowNewPopup windowSetTransientFor window mainWindow@@ -118,7 +119,7 @@ treeViewSetCursor tree [if direction then min 1 (n-1) else (n-1)] Nothing widgetShowAll window return tree- modifyIDE_ (\ide -> return (ide{currentState = IsFlipping tree'}))+ modifyIDE_ (\ide -> ide{currentState = IsFlipping tree'}) return () handleKeyRelease :: TreeViewClass alpha => alpha -> IDERef -> Event -> IO (Bool)@@ -131,7 +132,7 @@ (treePath, _) <- treeViewGetCursor tree Just column <- treeViewGetColumn tree 0 treeViewRowActivated tree treePath column- reflectIDE (modifyIDE_ (\ide -> return (ide{currentState = IsRunning}))) ideR+ reflectIDE (modifyIDE_ (\ide -> ide{currentState = IsRunning})) ideR return False _ -> return False (_,_,_) -> return False
src/IDE/Package.hs view
@@ -26,11 +26,10 @@ , packageClean , packageCopy , packageRun-, nextError-, previousError , activatePackage , deactivatePackage , getActivePackage+, belongsToActivePackage -- :: FilePath -> IDEM Bool , packageInstall , packageRegister@@ -45,6 +44,9 @@ , backgroundBuildToggled , backgroundLinkToggled++, debugStart+, debugToggled ) where import Graphics.UI.Gtk@@ -57,28 +59,25 @@ import System.FilePath import Control.Concurrent import System.Directory- (doesFileExist, setCurrentDirectory, canonicalizePath)-import System.IO (Handle(..), hClose, hGetLine, hSetBuffering)+ (doesFileExist, setCurrentDirectory) import Prelude hiding (catch)-import Text.ParserCombinators.Parsec.Language-import qualified Text.ParserCombinators.Parsec.Token as P-import Text.ParserCombinators.Parsec hiding(Parser) import Data.Maybe (isJust, fromJust) import Control.Exception (SomeException(..), catch) -import IDE.Pane.Log-import Control.Event import IDE.Core.State import IDE.Pane.PackageEditor import IDE.Pane.SourceBuffer import IDE.Pane.PackageFlags-import IDE.Metainfo.Provider import Distribution.Text (display)-import IDE.FileUtils (getConfigFilePathForLoad)+import IDE.FileUtils+ (moduleNameFromFilePath', isSubPath, getConfigFilePathForLoad)+import IDE.LogRef+import IDE.Debug import MyMissing (replace) import Distribution.ModuleName (ModuleName(..))-import Data.List (isPrefixOf, foldl')+import Data.List (nub, foldl') import qualified System.IO.UTF8 as UTF8 (readFile)+import IDE.Tool (ToolOutput(..), runTool, newGhci, ToolState(..)) #if defined(mingw32_HOST_OS) || defined(__MINGW32__) import System.Process (getProcessExitCode, ProcessHandle(..))@@ -103,7 +102,13 @@ import System.Posix.Signals (Handler(..)) import Foreign.C (Errno(..), getErrno) #endif-import GHC.IOBase (BufferMode(..))+-- Leave at least one import ofter this #endif+-- so the auto import tool does not add stuf insied the+import IDE.Metainfo.Provider+ (rebuildActiveInfo)+import qualified Data.Set as Set (member, fromList)+import qualified Data.Map as Map (empty, insert, lookup)+import IDE.SourceCandy (getCandylessText) #if defined(mingw32_HOST_OS) || defined(__MINGW32__) foreign import stdcall unsafe "winbase.h GetCurrentProcessId"@@ -137,8 +142,7 @@ selectActivePackage :: Maybe FilePath -> IDEM (Maybe IDEPackage) selectActivePackage mbFilePath' = do- ideR <- ask- window <- readIDE window+ window <- getMainWindow mbFilePath <- case mbFilePath' of Nothing -> liftIO $ choosePackageFile window Just fp -> return (Just fp)@@ -160,16 +164,15 @@ else return False if wantToLoadSession then do- triggerEvent ideR (LoadSession (ppath </> "IDE.session"))+ triggerEventIDE (LoadSession (ppath </> "IDE.session")) readIDE activePack else activatePackage filePath activatePackage :: FilePath -> IDEM (Maybe IDEPackage) activatePackage filePath = do- ideR <- ask let ppath = dropFileName filePath- liftIO $ setCurrentDirectory ppath mbPackageD <- reifyIDE (\ideR -> catch (do+ liftIO $ setCurrentDirectory ppath pd <- readPackageDescription normal filePath return (Just (flattenPackageDescription pd))) (\(e :: SomeException) -> do@@ -178,36 +181,71 @@ case mbPackageD of Nothing -> return (Nothing) Just packageD -> do- let packp = IDEPackage (package packageD) filePath (buildDepends packageD) [] [] [] [] [] [] [] []+ let modules = Set.fromList $ libModules packageD ++ exeModules packageD+ let files = Set.fromList $ extraSrcFiles packageD ++ map modulePath (executables packageD)+ let srcDirs = nub $ concatMap hsSourceDirs (allBuildInfo packageD)+ let packp = IDEPackage (package packageD) filePath (buildDepends packageD) modules+ files srcDirs [] [] [] [] [] [] [] [] pack <- (do flagFileExists <- liftIO $ doesFileExist (ppath </> "IDE.flags") if flagFileExists then liftIO $ readFlags (ppath </> "IDE.flags") packp else return packp)- modifyIDE_ (\ide -> return (ide{activePack = (Just pack)}))+ modifyIDE_ (\ide -> ide{activePack = (Just pack), projFilesCache = Map.empty}) ide <- getIDE- triggerEvent ideR ActivePack- triggerEvent ideR (Sensitivity [(SensitivityProjectActive,True)])+ triggerEventIDE ActivePack+ triggerEventIDE (Sensitivity [(SensitivityProjectActive,True)]) sb <- getSBActivePackage liftIO $ statusbarPop sb 1 liftIO $ statusbarPush sb 1 (display $ packageId pack) removeRecentlyUsedPackage filePath return (Just pack) ++belongsToActivePackage :: IDEBuffer -> IDEM Bool+belongsToActivePackage ideBuf =+ case fileName ideBuf of+ Nothing -> return False+ Just fp -> do+ projFilesCache' <- readIDE projFilesCache+ activePack' <- readIDE activePack+ case Map.lookup fp projFilesCache' of+ Just b -> return b+ Nothing -> case activePack' of+ Nothing -> return False+ Just pack -> let basePath = dropFileName $ cabalFile pack in do+ r <- if isSubPath basePath fp+ then+ let srcPaths = map (\srcP -> basePath </> srcP) (srcDirs pack)+ relPaths = map (\p -> makeRelative p fp) srcPaths in+ if or (map (\p -> Set.member p (extraSrcs pack)) relPaths)+ then return True+ else do+ -- do+ gtkbuf <- liftIO $ textViewGetBuffer (sourceView ideBuf)+ candy <- readIDE candy+ text <- liftIO $ getCandylessText candy gtkbuf+ mbMn <- liftIO $ moduleNameFromFilePath' fp text+ case mbMn of+ Nothing -> return False+ Just mn -> return (Set.member mn (modules pack))+ else return False+ modifyIDE_ (\ide -> ide{projFilesCache =+ Map.insert fp r projFilesCache'})+ return r+ deactivatePackage :: IDEAction deactivatePackage = do- ideR <- ask oldActivePack <- readIDE activePack when (isJust oldActivePack) $ do- triggerEvent ideR (SaveSession+ triggerEventIDE (SaveSession ((dropFileName . cabalFile . fromJust) oldActivePack </> "IDE.session")) addRecentlyUsedPackage ((cabalFile . fromJust) oldActivePack) return ()- modifyIDE_ (\ide -> return (ide{activePack = Nothing}))- ideR <- ask- triggerEvent ideR ActivePack+ modifyIDE_ (\ide -> ide{activePack = Nothing, projFilesCache = Map.empty})+ triggerEventIDE ActivePack when (isJust oldActivePack) $ do- triggerEvent ideR (Sensitivity [(SensitivityProjectActive,False)])+ triggerEventIDE (Sensitivity [(SensitivityProjectActive,False)]) return () sb <- getSBActivePackage liftIO $ statusbarPop sb 1@@ -217,15 +255,12 @@ packageConfig :: IDEAction packageConfig = catchIDE (do mbPackage <- getActivePackage- log <- getLog case mbPackage of Nothing -> return () Just package -> do mbPackageD <- reifyIDE (\ideR -> catch (do- (inp,out,err,pid) <- runExternal "runhaskell" (["Setup","configure"]- ++ (configFlags package))- oid <- forkIO(readOut log out)- eid <- forkIO (readErr log err)+ reflectIDE (runExternalTool "Configuring" "runhaskell" (["Setup","configure"]+ ++ (configFlags package)) logOutput) ideR pd <- readPackageDescription normal (cabalFile package) return (Just (flattenPackageDescription pd))) (\(e :: SomeException) -> do@@ -233,185 +268,184 @@ return Nothing)) case mbPackageD of Just packageD -> do- modifyIDE_ (\ide -> return (ide{activePack =- Just package{depends=buildDepends packageD}}))- ask >>= \ideR -> triggerEvent ideR ActivePack+ let modules = Set.fromList $ libModules packageD ++ exeModules packageD+ let files = Set.fromList $ extraSrcFiles packageD ++ map modulePath (executables packageD)+ let srcDirs = nub $ concatMap hsSourceDirs (allBuildInfo packageD)+ modifyIDE_ (\ide -> ide{activePack =+ Just package{depends=buildDepends packageD, modules = modules,+ extraSrcs = files, srcDirs = srcDirs}})+ triggerEventIDE ActivePack return () Nothing -> return ()) (\(e :: SomeException) -> putStrLn (show e)) +runExternalTool :: String -> FilePath -> [String] -> ([ToolOutput] -> IDEAction) -> IDEAction+runExternalTool description executable args handleOutput = do+ prefs <- readIDE prefs+ alreadyRunning <- isRunning+ unless alreadyRunning $ do+ when (saveAllBeforeBuild prefs) (do fileSaveAll belongsToActivePackage; return ())+ sb <- getSBErrors+ liftIO $statusbarPop sb 1+ liftIO $statusbarPush sb 1 description+ reifyIDE (\ideR -> forkIO $ do+ (output, pid) <- runTool executable args+ reflectIDE (do+ modifyIDE_ (\ide -> ide{runningTool = Just pid})+ handleOutput output) ideR)+ return ()++runCabalBuild :: Bool -> IDEPackage -> IDEAction+runCabalBuild backgroundBuild package = do+ prefs <- readIDE prefs+ let args = (["Setup","build"] +++ if ((not backgroundBuild) || (backgroundLink prefs))+ then []+ else ["--ghc-options=-c", "--with-ar=true", "--with-ld=true"]+ ++ buildFlags package)+ runExternalTool "Building" "runhaskell" args $ \output -> do+ logOutputForBuild backgroundBuild output+ errs <- readIDE errorRefs+ when ((not backgroundBuild)+ && (collectAfterBuild prefs)+ && (not (any isError errs))) $ do+ ideMessage Normal "Update meta info for active package"+ rebuildActiveInfo+ packageBuild :: Bool -> IDEAction packageBuild backgroundBuild = catchIDE (do- mbPackage <- if backgroundBuild then readIDE activePack else getActivePackage- log <- getLog+ mbPackage <- if backgroundBuild+ then readIDE activePack+ else getActivePackage ideR <- ask prefs <- readIDE prefs case mbPackage of Nothing -> return () Just package -> do- modified <- if (saveAllBeforeBuild prefs) then fileCheckAll else return False- when ((not backgroundBuild) || modified) $ do- alreadyRunning <- isRunning- if alreadyRunning- then do- interruptBuild- when (not backgroundBuild) $ liftIO $ do- timeoutAddFull (do- reflectIDE (do packageBuild False; return False) ideR- return False) priorityDefaultIdle 100- return ()- else do- when (saveAllBeforeBuild prefs) (do fileSaveAll; return ())- sb <- getSBErrors- liftIO $statusbarPop sb 1- liftIO $statusbarPush sb 1 "Building"- reifyIDE (\ideR -> forkIO $ do- let args = (["Setup","build"] ++- if ((not backgroundBuild) || (backgroundLink prefs))- then []- else ["--ghc-options=-c", "--with-ar=true", "--with-ld=true"]- ++ buildFlags package)- (inp,out,err,pid) <- runExternal "runhaskell" args- oid <- forkIO (readOut log out)- hSetBuffering err NoBuffering- eid <- forkIO (reflectIDE (readErrForBuild backgroundBuild log err) ideR)- reflectIDE (modifyIDE_ (\ide -> return ide{buildProcess = Just pid})) ideR- when ((not backgroundBuild) && (collectAfterBuild prefs)) $ reflectIDE (mayRebuildInBackground (Just pid)) ideR- return ())- return ())+ modified <- if saveAllBeforeBuild prefs+ then fileCheckAll belongsToActivePackage+ else return False+ when (not backgroundBuild || modified) $ do+ maybeGhci <- readIDE ghciState+ case maybeGhci of+ Nothing -> do+ alreadyRunning <- isRunning+ if alreadyRunning+ then do+ interruptBuild+ when (not backgroundBuild) $ liftIO $ do+ timeoutAddFull (do+ reflectIDE (do packageBuild False; return False) ideR+ return False) priorityDefaultIdle 100+ return ()+ else runCabalBuild backgroundBuild package+ Just ghci -> do+ ready <- liftIO $ isEmptyMVar (currentToolCommand ghci)+ when ready $ do+ when (saveAllBeforeBuild prefs) (do fileSaveAll belongsToActivePackage; return ())+ executeDebugCommand ":reload" $ logOutputForBuild backgroundBuild+ ) (\(e :: SomeException) -> putStrLn (show e)) packageDoc :: IDEAction packageDoc = catchIDE (do mbPackage <- getActivePackage- log <- getLog case mbPackage of Nothing -> return ()- Just package -> liftIO $do- (inp,out,err,pid) <- runExternal "runhaskell" (["Setup","haddock"]- ++ (haddockFlags package))- oid <- forkIO (readOut log out)- eid <- forkIO (readErr log err)- return ())+ Just package -> runExternalTool "Documenting" "runhaskell" (["Setup","haddock"]+ ++ (haddockFlags package)) logOutput) (\(e :: SomeException) -> putStrLn (show e)) packageClean :: IDEAction packageClean = do mbPackage <- getActivePackage- log <- getLog case mbPackage of Nothing -> return ()- Just package -> liftIO $do- (inp,out,err,pid) <- runExternal "runhaskell" ["Setup","clean"]- oid <- forkIO (readOut log out)- eid <- forkIO (readErr log err)- return ()+ Just package -> runExternalTool "Cleaning" "runhaskell" ["Setup","clean"] logOutput packageCopy :: IDEAction packageCopy = catchIDE (do mbPackage <- getActivePackage- log <- getLog mbDir <- chooseDir "Select the target directory" case mbDir of Nothing -> return () Just fp -> case mbPackage of Nothing -> return ()- Just package -> liftIO $ do- (inp,out,err,pid) <- runExternal "runhaskell" (["Setup","copy"]- ++ ["--destdir=" ++ fp])- oid <- forkIO (readOut log out)- eid <- forkIO (readErr log err)- return ())+ Just package -> runExternalTool "Copying" "runhaskell" (["Setup","copy"]+ ++ ["--destdir=" ++ fp]) logOutput) (\(e :: SomeException) -> putStrLn (show e)) packageRun :: IDEAction packageRun = catchIDE (do+ ideR <- ask mbPackage <- getActivePackage- log <- getLog+ maybeGhci <- readIDE ghciState case mbPackage of Nothing -> return ()- Just package -> liftIO $do- pd <- readPackageDescription normal (cabalFile package) >>= return . flattenPackageDescription- case executables pd of- [(Executable name _ _)] -> do- let path = "dist/build" </> name </> name- (inp,out,err,pid) <- runExternal path (exeFlags package)- oid <- forkIO (readOut log out)- eid <- forkIO (readErr log err)- return ()- otherwise -> do- sysMessage Normal "no single executable in selected package"- return ())+ Just package -> do+ pd <- liftIO $ readPackageDescription normal (cabalFile package) >>= return . flattenPackageDescription+ case maybeGhci of+ Nothing -> do+ case executables pd of+ (Executable name _ _):_ -> do+ let path = "dist/build" </> name </> name+ runExternalTool ("Running "++name) path (exeFlags package) logOutput+ otherwise -> do+ sysMessage Normal "no executable in selected package"+ return ()+ Just ghci -> do+ case executables pd of+ (Executable _ mainFilePath _):_ -> do+ executeDebugCommand (":module " ++ (map (\c -> if c == '/' then '.' else c) (takeWhile (/= '.') mainFilePath))) logOutput+ executeDebugCommand (":main " ++ (unwords (exeFlags package))) logOutput+ otherwise -> do+ sysMessage Normal "no executable in selected package"+ return ()) (\(e :: SomeException) -> putStrLn (show e)) packageInstall :: IDEAction packageInstall = catchIDE (do mbPackage <- getActivePackage- log <- getLog case mbPackage of Nothing -> return ()- Just package -> liftIO $ do- (inp,out,err,pid) <- runExternal "runhaskell" (["Setup","install"]- ++ (installFlags package))- oid <- forkIO (readOut log out)- eid <- forkIO (readErr log err)- return ())+ Just package -> runExternalTool "Installing" "runhaskell" (["Setup","install"]+ ++ (installFlags package)) logOutput) (\(e :: SomeException) -> putStrLn (show e)) packageRegister :: IDEAction packageRegister = catchIDE (do mbPackage <- getActivePackage- log <- getLog case mbPackage of Nothing -> return ()- Just package -> liftIO $do- (inp,out,err,pid) <- runExternal "runhaskell" (["Setup","register"]- ++ (registerFlags package))- oid <- forkIO (readOut log out)- eid <- forkIO (readErr log err)- return ())+ Just package -> runExternalTool "Registering" "runhaskell" (["Setup","register"]+ ++ (registerFlags package)) logOutput) (\(e :: SomeException) -> putStrLn (show e)) packageUnregister :: IDEAction packageUnregister = catchIDE (do mbPackage <- getActivePackage- log <- getLog case mbPackage of Nothing -> return ()- Just package -> liftIO $do- (inp,out,err,pid) <- runExternal "runhaskell" (["Setup","unregister"]- ++ (unregisterFlags package))- oid <- forkIO (readOut log out)- eid <- forkIO (readErr log err)- return ())+ Just package -> runExternalTool "Unregistering" "runhaskell" (["Setup","unregister"]+ ++ (unregisterFlags package)) logOutput) (\(e :: SomeException) -> putStrLn (show e)) packageTest :: IDEAction packageTest = catchIDE (do mbPackage <- getActivePackage- log <- getLog case mbPackage of Nothing -> return ()- Just package -> liftIO $do- (inp,out,err,pid) <- runExternal "runhaskell" (["Setup","test"])- oid <- forkIO (readOut log out)- eid <- forkIO (readErr log err)- return ())+ Just package -> runExternalTool "Testing" "runhaskell" (["Setup","test"]) logOutput) (\(e :: SomeException) -> putStrLn (show e)) packageSdist :: IDEAction packageSdist = catchIDE (do mbPackage <- getActivePackage- log <- getLog case mbPackage of Nothing -> return ()- Just package -> liftIO $do- (inp,out,err,pid) <- runExternal "runhaskell" (["Setup","sdist"]- ++ (sdistFlags package))- oid <- forkIO (readOut log out)- eid <- forkIO (readErr log err)- return ())+ Just package -> runExternalTool "Source Dist" "runhaskell" (["Setup","sdist"]+ ++ (sdistFlags package)) logOutput) (\(e :: SomeException) -> putStrLn (show e)) @@ -419,7 +453,6 @@ packageOpenDoc = catchIDE (do mbPackage <- getActivePackage prefs <- readIDE prefs- log <- getLog case mbPackage of Nothing -> return () Just package ->@@ -428,17 +461,13 @@ </> display (pkgName (packageId package)) </> display (pkgName (packageId package)) </> "index.html"- in liftIO $do- (inp,out,err,pid) <- runExternal (browser prefs) [path]- oid <- forkIO (readOut log out)- eid <- forkIO (readErr log err)- return ())+ in runExternalTool "Opening Documentation" (browser prefs) [path] logOutput) (\(e :: SomeException) -> putStrLn (show e)) chooseDir :: String -> IDEM (Maybe FilePath) chooseDir str = do- win <- readIDE window+ win <- getMainWindow liftIO $do dialog <- fileChooserDialogNew (Just $ str)@@ -470,7 +499,7 @@ isRunning :: IDEM Bool #if defined(mingw32_HOST_OS) || defined(__MINGW32__) isRunning = do- maybeProcess <- readIDE buildProcess+ maybeProcess <- readIDE runningTool liftIO $ do case maybeProcess of Just process -> do@@ -489,13 +518,13 @@ liftIO $ (do group <- getProcessGroupID status <- getGroupProcessStatus False False group- putStrLn $ "Status " ++ show status+ -- putStrLn $ "Status " ++ show status case status of Just _ -> reflectIDE isRunning ideR Nothing -> return True) `catch` (\(e :: IOError) -> do Errno errno <- liftIO $ getErrno- putStrLn $ "Error " ++ show errno+ -- putStrLn $ "Error " ++ show errno return $ errno /= 10) #endif @@ -503,7 +532,7 @@ #if defined(mingw32_HOST_OS) || defined(__MINGW32__) interruptBuild = do -- I can't get this to work- --maybeProcess <- readIDE buildProcess+ --maybeProcess <- readIDE runningTool --liftIO $ do -- processGroupId <- case maybeProcess of -- Just h -> do@@ -528,193 +557,6 @@ return () #endif -readErrForBuild :: Bool -> IDELog -> Handle -> IDEAction-readErrForBuild backgroundBuild log hndl = do- ideRef <- ask- errs <- liftIO $readAndShow ideRef False []- unmarkErrors- modifyIDE_ (\ide -> return (ide{errors = reverse errs, currentErr = Nothing}))- markErrors- triggerEvent ideRef (Sensitivity [(SensitivityError,not (null errs))])- sb <- getSBErrors- let errorNum = length (filter isError errs)- let warnNum = length errs - errorNum- liftIO $statusbarPop sb 1- liftIO $statusbarPush sb 1 $show errorNum ++ " Errors, " ++ show warnNum ++ " Warnings"- when ((not backgroundBuild) && (not (null errs))) nextError- where- readAndShow :: IDERef -> Bool -> [ErrorSpec] -> IO [ErrorSpec]- readAndShow ideR inError errs = catch (do- line <- hGetLine hndl- tag <- case line of- '[' : _ -> return LogTag- _ | "Linking " `isPrefixOf` line || "ar:" `isPrefixOf` line || "ld:" `isPrefixOf` line -> do- -- when backgroundBuild $ reflectIDE interruptProcess ideR- postGUISync $ reflectIDE (do- unmarkErrors- modifyIDE_ (\ide -> return (ide{errors = reverse errs, currentErr = Nothing}))- markErrors- ) ideR- return LogTag- _ -> return ErrorTag- let parsed = parse buildLineParser "" line- lineNr <- appendLog log (line ++ "\n") tag- case (parsed, errs) of- (Left e,_) -> do- sysMessage Normal (show e)- readAndShow ideR False errs- (Right ne@(ErrorLine fp l c str),_) ->- readAndShow ideR True ((ErrorSpec fp l c str (lineNr,lineNr) True):errs)- (Right (OtherLine str1),(ErrorSpec fp i1 i2 str (l1,l2) isError):tl) ->- if inError- then readAndShow ideR True ((ErrorSpec fp i1 i2- (if null str- then line- else str ++ "\n" ++ line)- (l1,lineNr) isError) : tl)- else readAndShow ideR False errs- (Right (WarningLine str1),(ErrorSpec fp i1 i2 str (l1,l2) isError):tl) ->- if inError- then readAndShow ideR True ((ErrorSpec fp i1 i2- (if null str- then line- else str ++ "\n" ++ line)- (l1,lineNr) False) : tl)- else readAndShow ideR False errs- otherwise -> readAndShow ideR False errs)- (\ (_ :: SomeException) -> do- hClose hndl- let errorNum = length (filter isError errs)- let warnNum = length errs - errorNum- case errs of- [] -> appendLog log "Finished.\n" LogTag- _ -> appendLog log ("Finished. " ++ show errorNum ++ " errors - "- ++ show warnNum ++ " warnings.") LogTag- return errs)--selectErr :: Int -> IDEAction-selectErr index = do- errors <- readIDE errors- if length errors < index + 1- then return ()- else do- let thisErr = errors !! index- mbBuf <- selectSourceBuf (filePath thisErr)- case mbBuf of- Just buf -> markErrorInSourceBuf index buf (line thisErr) (column thisErr)- (errDescription thisErr) True- Nothing -> return ()- log :: IDELog <- getLog- liftIO $ markErrorInLog log (logLines thisErr)--forOpenErrors :: (Int -> ErrorSpec -> IDEBuffer -> IDEAction) -> IDEAction-forOpenErrors f = do- errors <- readIDE errors- allBufs <- allBuffers- forM_ [0 .. ((length errors)-1)] (\index -> do- let error = errors !! index- fpc <- liftIO $ canonicalizePath $ filePath error- forM_ (filter (\buf -> case (fileName buf) of- Just fn -> equalFilePath fpc fn- Nothing -> False) allBufs) (f index error))--markErrors :: IDEAction-markErrors = do- forOpenErrors (\index error buf -> do- markErrorInSourceBuf index buf (line error) (column error)- (errDescription error) False- return())--unmarkErrors :: IDEAction-unmarkErrors = do- forOpenErrors (\index error buf -> liftIO $ do- gtkbuf <- textViewGetBuffer (sourceView buf)- i1 <- textBufferGetStartIter gtkbuf- i2 <- textBufferGetEndIter gtkbuf- textBufferRemoveTagByName gtkbuf ("Err" ++ show index) i1 i2)--nextError :: IDEAction-nextError = do- errs <- readIDE errors- currentErr <- readIDE currentErr- if null errs- then return ()- else do- case currentErr of- Nothing -> do- modifyIDE_ (\ide -> return (ide{currentErr = Just 0}))- selectErr 0- Just n | (n + 1) < length errs -> do- modifyIDE_ (\ide -> return (ide{currentErr = Just (n + 1)}))- selectErr (n + 1)- Just n -> selectErr n--previousError :: IDEAction-previousError = do- errs <- readIDE errors- currentErr <- readIDE currentErr- if null errs- then return ()- else do- case currentErr of- Nothing -> do- modifyIDE_ (\ide -> return (ide{currentErr = Just (length errs - 1)}))- selectErr (length errs - 1)- Just n | n > 0 -> do- modifyIDE_ (\ide -> return (ide{currentErr = Just (n - 1)}))- selectErr (n - 1)- otherwise -> selectErr 0--data BuildError = BuildLine- | EmptyLine- | ErrorLine FilePath Int Int String- | WarningLine String- | OtherLine String--buildLineParser :: CharParser () BuildError-buildLineParser = try (do- char '['- integer- symbol "of"- integer- char '['- many (anyChar)- return BuildLine)- <|> try (do- filePath <- many (noneOf ":")- char ':'- line <- integer- char ':'- column <- integer- char ':'- whiteSpace- text <- many anyChar- return (ErrorLine filePath (fromIntegral line) (fromIntegral column) text))- <|> try (do- whiteSpace- eof- return EmptyLine)- <|> try (do- whiteSpace- symbol "Warning:"- text <- many anyChar- return (WarningLine ("Warning:" ++ text)))- <|> try (do- text <- many anyChar- eof- return (OtherLine text))- <?> "buildLineParser"---lexer = P.makeTokenParser emptyDef-lexeme = P.lexeme lexer-whiteSpace = P.whiteSpace lexer-hexadecimal = P.hexadecimal lexer-symbol = P.symbol lexer-identifier = P.identifier lexer-colon = P.colon lexer-integer = P.integer lexer- -- --------------------------------------------------------------------- -- | * Utility functions/procedures, that have to do with packages --@@ -758,7 +600,7 @@ if hasConfigs gpd then do reflectIDE (ideMessage High- "Cabal File with configurations can't be automatically updated") ideR+ "Cabal file with configurations can't be automatically updated with the current version of Leksah") ideR else let pd = flattenPackageDescription gpd npd = if isExposed && isJust (library pd)@@ -786,8 +628,8 @@ 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+ modifyIDE_ (\ide -> ide{recentPackages = take 12 (fp : recentPackages')})+ triggerEventIDE UpdateRecent return () removeRecentlyUsedPackage :: FilePath -> IDEAction@@ -796,16 +638,63 @@ 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+ modifyIDE_ (\ide -> ide{recentPackages = filter (\e -> e /= fp) recentPackages'})+ triggerEventIDE UpdateRecent return () backgroundBuildToggled :: IDEAction backgroundBuildToggled = do toggled <- getBackgroundBuildToggled- modifyIDE_ (\ide -> return (ide{prefs = (prefs ide){backgroundBuild= toggled}}))+ modifyIDE_ (\ide -> ide{prefs = (prefs ide){backgroundBuild= toggled}}) backgroundLinkToggled :: IDEAction backgroundLinkToggled = do toggled <- getBackgroundLinkToggled- modifyIDE_ (\ide -> return (ide{prefs = (prefs ide){backgroundLink= toggled}}))+ modifyIDE_ (\ide -> ide{prefs = (prefs ide){backgroundLink= toggled}})++-- ---------------------------------------------------------------------+-- | * Debug code that needs to use the package+--++debugStart :: IDEAction+debugStart = catchIDE (do+ ideRef <- ask+ mbPackage <- getActivePackage+ prefs' <- readIDE prefs+ case mbPackage of+ Nothing -> return ()+ Just package -> do+ maybeGhci <- readIDE ghciState+ case maybeGhci of+ Nothing -> do+ ghci <- reifyIDE $ \ideR -> newGhci (buildFlags package) (interactiveFlags prefs')+ $ \output -> reflectIDE (logOutputForBuild True output) ideR+ modifyIDE_ (\ide -> ide {ghciState = Just ghci})+ triggerEventIDE (Sensitivity [(SensitivityInterpreting, True)])+ -- Fork a thread to wait for the output from the process to close+ liftIO $ forkIO $ do+ readMVar (outputClosed ghci)+ reflectIDE (do+ modifyIDE_ (\ide -> ide {ghciState = Nothing})+ triggerEventIDE (Sensitivity [(SensitivityInterpreting, False)])+ -- Kick of a build if one is not already due+ modified <- fileCheckAll belongsToActivePackage+ prefs <- readIDE prefs+ when ((not modified) && (backgroundBuild prefs)) $ do+ mbPackage <- readIDE activePack+ case mbPackage of+ Just package -> runCabalBuild True package+ Nothing -> return ()) ideRef+ return ()+ _ -> do+ sysMessage Normal "Debugger already running"+ return ())+ (\(e :: SomeException) -> putStrLn (show e))++debugToggled :: IDEAction+debugToggled = do+ toggled <- getDebugToggled+ if toggled+ then debugStart+ else debugQuit+
+ src/IDE/Pane/Breakpoints.hs view
@@ -0,0 +1,240 @@+{-# OPTIONS_GHC -XRecordWildCards -XTypeSynonymInstances -XMultiParamTypeClasses+ -XDeriveDataTypeable #-}+-----------------------------------------------------------------------------+--+-- Module : IDE.Pane.Breakpoints+-- Copyright : 2007-2009 Juergen Nicklisch-Franken, Hamish Mackenzie+-- License : GPL+--+-- Maintainer : maintainer@leksah.org+-- Stability : provisional+-- Portability :+--+-- |+--+-----------------------------------------------------------------------------++module IDE.Pane.Breakpoints (+ IDEBreakpoints+, BreakpointsState+, showBreakpointList+, showBreakpointList'+, fillBreakpointList+, selectBreak+) where++import Graphics.UI.Gtk+import Data.Typeable (Typeable(..))+import IDE.Core.State+import Control.Monad.Reader+import Graphics.UI.Gtk.Gdk.Events (Event(..))+import Graphics.UI.Gtk.General.Enums+ (Click(..), MouseButton(..))+import IDE.Debug+ (debugShowBreakpoints,+ debugDeleteBreakpoint,+ debugDeleteAllBreakpoints)+import IDE.LogRef (showSourceSpan)+import Debug.Trace (trace)+import Data.List (elemIndex)+++-- | A breakpoints pane description+--+data IDEBreakpoints = IDEBreakpoints {+ scrolledView :: ScrolledWindow+, treeView :: TreeView+, breakpoints :: TreeStore LogRef+} deriving Typeable++data BreakpointsState = BreakpointsState {+} deriving(Eq,Ord,Read,Show,Typeable)+++instance IDEObject IDEBreakpoints++instance Pane IDEBreakpoints IDEM+ where+ primPaneName _ = "Breakpoints"+ getAddedIndex _ = 0+ getTopWidget = castToWidget . scrolledView+ paneId b = "*Breakpoints"+ makeActive pane = activatePane pane []+ close = closePane++instance RecoverablePane IDEBreakpoints BreakpointsState IDEM where+ saveState p = do+ return (Just BreakpointsState)+ recoverState pp BreakpointsState = do+ nb <- getNotebook pp+ newPane pp nb builder+ return ()++showBreakpointList :: IDEAction+showBreakpointList = trace "showBreakpointList!!" $ do+ m <- trace "now get breakpoints" getBreakpoints+ liftIO $ bringPaneToFront m+ liftIO $ widgetGrabFocus (treeView m)++getBreakpoints :: IDEM IDEBreakpoints+getBreakpoints = do+ mbBreakpoints <- getPane+ case mbBreakpoints of+ Nothing -> do+ pp <- getBestPathForId "*Breakpoints"+ nb <- getNotebook pp+ newPane pp nb builder+ mbBreakpoints <- getPane+ case mbBreakpoints of+ Nothing -> throwIDE "Can't init breakpoints"+ Just m -> return m+ Just m -> return m++showBreakpointList' :: PanePath -> IDEAction+showBreakpointList' pp = do+ m <- getBreakpoints' pp+ liftIO $ bringPaneToFront m+ liftIO $ widgetGrabFocus (treeView m)++getBreakpoints' :: PanePath -> IDEM IDEBreakpoints+getBreakpoints' pp = do+ mbBreakpoints <- getPane+ case mbBreakpoints of+ Nothing -> do+ layout <- getLayout+ nb <- getNotebook (getBestPanePath pp layout)+ newPane pp nb builder+ mbBreakpoints <- getPane+ case mbBreakpoints of+ Nothing -> throwIDE "Can't init breakpoints"+ Just m -> return m+ Just m -> return m++builder :: PanePath ->+ Notebook ->+ Window ->+ IDERef ->+ IO (IDEBreakpoints, Connections)+builder pp nb windows ideR = do+ breakpoints <- treeStoreNew []+ treeView <- treeViewNew+ treeViewSetModel treeView breakpoints++ rendererA <- cellRendererTextNew+ colA <- treeViewColumnNew+ treeViewColumnSetTitle colA "Location"+ treeViewColumnSetSizing colA TreeViewColumnAutosize+ treeViewColumnSetResizable colA True+ treeViewColumnSetReorderable colA True+ treeViewAppendColumn treeView colA+ cellLayoutPackStart colA rendererA False+ cellLayoutSetAttributes colA rendererA breakpoints+ $ \row -> [cellText := showSourceSpan row]++ rendererB <- cellRendererTextNew+ colB <- treeViewColumnNew+ treeViewColumnSetTitle colB "Breakpoints"+ treeViewColumnSetSizing colB TreeViewColumnAutosize+ treeViewColumnSetResizable colB True+ treeViewColumnSetReorderable colB True+ treeViewAppendColumn treeView colB+ cellLayoutPackStart colB rendererB False+ cellLayoutSetAttributes colB rendererB breakpoints+ $ \row -> [ cellText := refDescription row]++ treeViewSetHeadersVisible treeView True+ selB <- treeViewGetSelection treeView+ treeSelectionSetMode selB SelectionSingle+ scrolledView <- scrolledWindowNew Nothing Nothing+ containerAdd scrolledView treeView+ scrolledWindowSetPolicy scrolledView PolicyAutomatic PolicyAutomatic+ let pane = IDEBreakpoints scrolledView treeView breakpoints+ treeView `onButtonPress` (breakpointViewPopup ideR breakpoints treeView)+ cid1 <- treeView `afterFocusIn`+ (\_ -> do reflectIDE (makeActive pane) ideR ; return True)+ return (pane,[ConnectC cid1])++fillBreakpointList :: IDEAction+fillBreakpointList = do+ mbBreakpoints <- getPane+ case mbBreakpoints of+ Nothing -> return ()+ Just b -> do+ refs <- readIDE breakpointRefs+ liftIO $ do+ treeStoreClear (breakpoints b)+ mapM_ (insertBreak (breakpoints b)) (zip refs [0..length refs])+ where+ insertBreak treeStore (lr,index) = treeStoreInsert treeStore [] index lr++getSelectedBreakpoint :: TreeView+ -> TreeStore LogRef+ -> IO (Maybe LogRef)+getSelectedBreakpoint treeView treeStore = trace "Get selected breakpoint" $do+ treeSelection <- treeViewGetSelection treeView+ paths <- treeSelectionGetSelectedRows treeSelection+ case paths of+ a:r -> do+ val <- treeStoreGetValue treeStore a+ return (Just val)+ _ -> return Nothing++selectBreak :: Maybe LogRef -> IDEAction+selectBreak mbLogRef = do+ breakRefs' <- readIDE breakpointRefs+ breaks <- getBreakpoints+ liftIO $ do+ selection <- treeViewGetSelection (treeView breaks)+ case mbLogRef of+ Nothing -> treeSelectionUnselectAll selection+ Just lr -> case lr `elemIndex` breakRefs' of+ Nothing -> return ()+ Just ind -> treeSelectionSelectPath selection [ind]++breakpointViewPopup :: IDERef+ -> TreeStore LogRef+ -> TreeView+ -> Event+ -> IO (Bool)+breakpointViewPopup ideR store treeView (Button _ click _ _ _ _ button _ _)+ = do+ if button == RightButton+ then do+ theMenu <- menuNew+ item1 <- menuItemNewWithLabel "Remove breakpoint"+ item1 `onActivateLeaf` do+ sel <- getSelectedBreakpoint treeView store+ case sel of+ Just ref -> reflectIDE (deleteBreakpoint ref) ideR+ otherwise -> sysMessage Normal "Debugger>> breakpointViewPopup: no selection2"+ sep1 <- separatorMenuItemNew+ item2 <- menuItemNewWithLabel "Remove all breakpoints"+ item2 `onActivateLeaf` (reflectIDE debugDeleteAllBreakpoints ideR)+ item3 <- menuItemNewWithLabel "Update"+ item3 `onActivateLeaf` (reflectIDE debugShowBreakpoints ideR)+ mapM_ (menuShellAppend theMenu) [castToMenuItem item1, castToMenuItem sep1,+ castToMenuItem item2, castToMenuItem item3]+ menuPopup theMenu Nothing+ widgetShowAll theMenu+ return True+ else if button == LeftButton && click == DoubleClick+ then do sel <- getSelectedBreakpoint treeView store+ case sel of+ Just ref -> reflectIDE (setCurrentBreak (Just ref)) ideR+ otherwise -> sysMessage Normal "Debugger>> breakpointViewPopup: no selection2"+ return True+ else return False+breakpointViewPopup _ _ _ _ = throwIDE "breakpointViewPopup wrong event type"+++deleteBreakpoint :: LogRef -> IDEAction+deleteBreakpoint logRef =+ case logRefType logRef of+ BreakpointRef -> debugDeleteBreakpoint ((words (refDescription logRef)) !! 1) logRef+ _ -> sysMessage Normal "Debugger>>deleteBreakpoint: Not a breakpoint"++++++
src/IDE/Pane/ClassHierarchy.hs view
@@ -158,11 +158,10 @@ mbCH <- getPane case mbCH of Nothing -> do- prefs <- readIDE prefs- layout <- readIDE layout- let pp = getStandardPanePath (modulesPanePath prefs) layout- nb <- getNotebook pp- initClassHierarchy pp nb+ pp <- getBestPathForId "*ClassHierarchy"+ nb <- getNotebook pp+ ci <- readIDE currentInfo+ newPane pp nb (builder ci) mbCH <- getPane case mbCH of Nothing -> throwIDE "Can't init class hierarchy"@@ -244,117 +243,113 @@ sortTree :: Ord a => Tree a -> Tree a sortTree (Node l forest) = Node l (sort (map sortTree forest)) -initClassHierarchy :: PanePath -> Notebook -> IDEAction-initClassHierarchy panePath nb = do- panes <- readIDE panes- paneMap <- readIDE paneMap- prefs <- readIDE prefs- currentInfo <- readIDE currentInfo- (buf,cids) <- reifyIDE $ \ideR -> do---- Class Hierarchy- let forest = case currentInfo of- Nothing -> []- Just pair -> buildClassHierarchyTree pair- treeStore <- treeStoreNew forest- treeView <- treeViewNew- treeViewSetModel treeView treeStore- --treeViewSetRulesHint treeView True+builder :: Maybe (PackageScope, PackageScope) ->+ PanePath ->+ Notebook ->+ Window ->+ IDERef ->+ IO (IDEClassHierarchy, Connections)+builder currentInfo pp nb windows ideR = do+ let forest = case currentInfo of+ Nothing -> []+ Just pair -> buildClassHierarchyTree pair+ treeStore <- treeStoreNew forest+ treeView <- treeViewNew+ treeViewSetModel treeView treeStore+ --treeViewSetRulesHint treeView True - renderer0 <- cellRendererPixbufNew- set renderer0 [ cellPixbufStockId := "ide_no_source" ]+ renderer0 <- cellRendererPixbufNew+ set renderer0 [ cellPixbufStockId := "ide_no_source" ] - renderer <- cellRendererTextNew- col <- treeViewColumnNew- treeViewColumnSetTitle col "Classes"- treeViewColumnSetSizing col TreeViewColumnAutosize- treeViewColumnSetResizable col True- treeViewColumnSetReorderable col True- treeViewAppendColumn treeView col- cellLayoutPackStart col renderer0 False- cellLayoutPackStart col renderer True- cellLayoutSetAttributes col renderer treeStore- $ \(s,_,_) -> [ cellText := s]- cellLayoutSetAttributes col renderer0 treeStore- $ \(_,_,d) -> [- cellPixbufStockId :=- if isJust (mbLocation d)- then "ide_source"- else "ide_no_source"]+ renderer <- cellRendererTextNew+ col <- treeViewColumnNew+ treeViewColumnSetTitle col "Classes"+ treeViewColumnSetSizing col TreeViewColumnAutosize+ treeViewColumnSetResizable col True+ treeViewColumnSetReorderable col True+ treeViewAppendColumn treeView col+ cellLayoutPackStart col renderer0 False+ cellLayoutPackStart col renderer True+ cellLayoutSetAttributes col renderer treeStore+ $ \(s,_,_) -> [ cellText := s]+ cellLayoutSetAttributes col renderer0 treeStore+ $ \(_,_,d) -> [+ cellPixbufStockId :=+ if isJust (mbLocation d)+ then "ide_source"+ else "ide_no_source"] - treeViewSetHeadersVisible treeView True- -- treeViewSetEnableSearch treeView True- -- treeViewSetSearchColumn treeView 0- -- treeViewSetSearchEqualFunc treeView (treeViewSearch treeView treeStore)+ treeViewSetHeadersVisible treeView True+-- treeViewSetEnableSearch treeView True+-- treeViewSetSearchColumn treeView 0+-- treeViewSetSearchEqualFunc treeView (treeViewSearch treeView treeStore) -- Facet view {--- facetView <- treeViewNew- facetStore <- treeStoreNew []- treeViewSetModel facetView facetStore- renderer30 <- cellRendererPixbufNew- renderer31 <- cellRendererPixbufNew- renderer3 <- cellRendererTextNew- col <- treeViewColumnNew- treeViewColumnSetTitle col "Interface"- --treeViewColumnSetSizing col TreeViewColumnAutosize- treeViewAppendColumn facetView col- cellLayoutPackStart col renderer30 False- cellLayoutPackStart col renderer31 False- cellLayoutPackStart col renderer3 True- cellLayoutSetAttributes col renderer3 facetStore- $ \row -> [ cellText := facetTreeText row]- cellLayoutSetAttributes col renderer30 facetStore- $ \row -> [- cellPixbufStockId := stockIdFromType (facetIdType row)]- cellLayoutSetAttributes col renderer31 facetStore- $ \row -> [- cellPixbufStockId := if isJust (mbLocation(facetIdDescr row))- then "ide_source"- else ""]- treeViewSetHeadersVisible facetView True- treeViewSetEnableSearch facetView True- treeViewSetSearchColumn facetView 0- treeViewSetSearchEqualFunc facetView (facetViewSearch facetView facetStore)+ facetView <- treeViewNew+ facetStore <- treeStoreNew []+ treeViewSetModel facetView facetStore+ renderer30 <- cellRendererPixbufNew+ renderer31 <- cellRendererPixbufNew+ renderer3 <- cellRendererTextNew+ col <- treeViewColumnNew+ treeViewColumnSetTitle col "Interface"+ --treeViewColumnSetSizing col TreeViewColumnAutosize+ treeViewAppendColumn facetView col+ cellLayoutPackStart col renderer30 False+ cellLayoutPackStart col renderer31 False+ cellLayoutPackStart col renderer3 True+ cellLayoutSetAttributes col renderer3 facetStore+ $ \row -> [ cellText := facetTreeText row]+ cellLayoutSetAttributes col renderer30 facetStore+ $ \row -> [+ cellPixbufStockId := stockIdFromType (facetIdType row)]+ cellLayoutSetAttributes col renderer31 facetStore+ $ \row -> [+ cellPixbufStockId := if isJust (mbLocation(facetIdDescr row))+ then "ide_source"+ else ""]+ treeViewSetHeadersVisible facetView True+ treeViewSetEnableSearch facetView True+ treeViewSetSearchColumn facetView 0+ treeViewSetSearchEqualFunc facetView (facetViewSearch facetView facetStore) --}- pane' <- hPanedNew- sw <- scrolledWindowNew Nothing Nothing- containerAdd sw treeView- scrolledWindowSetPolicy sw PolicyAutomatic PolicyAutomatic+ pane' <- hPanedNew+ sw <- scrolledWindowNew Nothing Nothing+ containerAdd sw treeView+ scrolledWindowSetPolicy sw PolicyAutomatic PolicyAutomatic {-- sw2 <- scrolledWindowNew Nothing Nothing- containerAdd sw2 facetView- scrolledWindowSetPolicy sw2 PolicyAutomatic PolicyAutomatic--}- panedAdd1 pane' sw+ containerAdd sw2 facetView+ scrolledWindowSetPolicy sw2 PolicyAutomatic PolicyAutomatic--}+ panedAdd1 pane' sw -- panedAdd2 pane' sw2- (x,y) <- widgetGetSize nb- panedSetPosition pane' (x `quot` 2)- box <- hBoxNew True 2- rb1 <- radioButtonNewWithLabel "Local"- rb2 <- radioButtonNewWithLabelFromWidget rb1 "Package"- rb3 <- radioButtonNewWithLabelFromWidget rb1 "World"- toggleButtonSetActive rb3 True- cb <- checkButtonNewWithLabel "Blacklist"+ (x,y) <- widgetGetSize nb+ panedSetPosition pane' (x `quot` 2)+ box <- hBoxNew True 2+ rb1 <- radioButtonNewWithLabel "Local"+ rb2 <- radioButtonNewWithLabelFromWidget rb1 "Package"+ rb3 <- radioButtonNewWithLabelFromWidget rb1 "World"+ toggleButtonSetActive rb3 True+ cb <- checkButtonNewWithLabel "Blacklist" - boxPackStart box rb1 PackGrow 2- boxPackStart box rb2 PackGrow 2- boxPackStart box rb3 PackGrow 2- boxPackEnd box cb PackNatural 2+ boxPackStart box rb1 PackGrow 2+ boxPackStart box rb2 PackGrow 2+ boxPackStart box rb3 PackGrow 2+ boxPackEnd box cb PackNatural 2 - boxOuter <- vBoxNew False 2- boxPackStart boxOuter box PackNatural 2- boxPackStart boxOuter pane' PackGrow 2+ boxOuter <- vBoxNew False 2+ boxPackStart boxOuter box PackNatural 2+ boxPackStart boxOuter pane' PackGrow 2 - let classes = IDEClassHierarchy boxOuter pane' treeView treeStore- {--facetView facetStore--} rb1 rb2 rb3 cb- notebookInsertOrdered nb boxOuter (paneName classes) Nothing- widgetShowAll boxOuter- cid3 <- treeView `onRowActivated`- (\ treePath _ -> do- treeViewExpandRow treeView treePath False- return ())- cid1 <- treeView `afterFocusIn`- (\_ -> do reflectIDE (makeActive classes) ideR; return True)+ let classes = IDEClassHierarchy boxOuter pane' treeView treeStore+ {--facetView facetStore--} rb1 rb2 rb3 cb+ cid3 <- treeView `onRowActivated`+ (\ treePath _ -> do+ treeViewExpandRow treeView treePath False+ return ())+ cid1 <- treeView `afterFocusIn`+ (\_ -> do reflectIDE (makeActive classes) ideR; return True) -- cid2 <- facetView `afterFocusIn` -- (\_ -> do runReaderT (makeActive classes) ideR; return True) -- treeView `onButtonPress` (treeViewPopup ideR treeStore treeView)@@ -363,14 +358,12 @@ -- rb2 `onToggled` (runReaderT scopeSelection ideR) -- rb3 `onToggled` (runReaderT scopeSelection ideR) -- cb `onToggled` (runReaderT scopeSelection ideR)- sel <- treeViewGetSelection treeView+ sel <- treeViewGetSelection treeView -- sel `onSelectionChanged` (fillFacets treeView treeStore facetView facetStore) -- sel2 <- treeViewGetSelection facetView -- sel2 `onSelectionChanged` (fillInfo facetView facetStore ideR) - return (classes,[ConnectC cid1{--,ConnectC cid2--}, ConnectC cid3])- addPaneAdmin buf cids panePath- liftIO $widgetGrabFocus (paned buf)+ return (classes,[ConnectC cid1{--,ConnectC cid2--}, ConnectC cid3]) {--
+ src/IDE/Pane/Errors.hs view
@@ -0,0 +1,246 @@+{-# OPTIONS_GHC -XRecordWildCards -XTypeSynonymInstances -XMultiParamTypeClasses+ -XDeriveDataTypeable #-}+-----------------------------------------------------------------------------+--+-- Module : IDE.Pane.Errors+-- Copyright : 2007-2009 Juergen Nicklisch-Franken, Hamish Mackenzie+-- License : GPL+--+-- Maintainer : maintainer@leksah.org+-- Stability : provisional+-- Portability :+--+-- | A pane which displays a list of errors+--+-----------------------------------------------------------------------------++module IDE.Pane.Errors (+ IDEErrors+, ErrorsState+, showErrors+, showErrors'+, fillErrorList+, selectError+) where++import Graphics.UI.Gtk+import Data.Typeable (Typeable(..))+import IDE.Core.State+import Control.Monad.Reader+import IDE.LogRef+import Graphics.UI.Gtk.General.Enums+ (Click(..), MouseButton(..))+import Graphics.UI.Gtk.Gdk.Events (Event(..))+import IDE.ImportTool (addImport,parseNotInScope, addAllImports)+import Data.List (elemIndex)++-- | A breakpoints pane description+--+data IDEErrors = IDEErrors {+ scrolledView :: ScrolledWindow+, treeView :: TreeView+, errorStore :: TreeStore ErrColumn+} deriving Typeable++data ErrColumn = ErrColumn {logRef :: LogRef, string :: String, index :: Int}++data ErrorsState = ErrorsState {+} deriving(Eq,Ord,Read,Show,Typeable)+++instance IDEObject IDEErrors++instance Pane IDEErrors IDEM+ where+ primPaneName _ = "Errors"+ getAddedIndex _ = 0+ getTopWidget = castToWidget . scrolledView+ paneId b = "*Errors"+ makeActive pane = activatePane pane []+ close = closePane++instance RecoverablePane IDEErrors ErrorsState IDEM where+ saveState p = do+ return (Just ErrorsState)+ recoverState pp ErrorsState = do+ nb <- getNotebook pp+ newPane pp nb builder+ fillErrorList+ return ()++showErrors :: IDEAction+showErrors = do+ m <- getErrors+ liftIO $ bringPaneToFront m+ liftIO $ widgetGrabFocus (treeView m)++getErrors :: IDEM IDEErrors+getErrors = do+ mbErrors <- getPane+ case mbErrors of+ Nothing -> do+ pp <- getBestPathForId "*Errors"+ nb <- getNotebook pp+ newPane pp nb builder+ fillErrorList+ mbErrors <- getPane+ case mbErrors of+ Nothing -> throwIDE "Can't init errors"+ Just m -> return m+ Just m -> return m++showErrors' :: PanePath -> IDEAction+showErrors' pp = do+ m <- getErrors' pp+ liftIO $ bringPaneToFront m+ liftIO $ widgetGrabFocus (treeView m)++getErrors' :: PanePath -> IDEM IDEErrors+getErrors' pp = do+ mbErrors <- getPane+ case mbErrors of+ Nothing -> do+ layout <- getLayout+ nb <- getNotebook (getBestPanePath pp layout)+ newPane pp nb builder+ fillErrorList+ mbErrors <- getPane+ case mbErrors of+ Nothing -> throwIDE "Can't init errors"+ Just m -> return m+ Just m -> return m++builder :: PanePath ->+ Notebook ->+ Window ->+ IDERef ->+ IO (IDEErrors, Connections)+builder pp nb windows ideR = do+ errorStore <- treeStoreNew []+ treeView <- treeViewNew+ treeViewSetModel treeView errorStore++ rendererA <- cellRendererTextNew+ colA <- treeViewColumnNew+ treeViewColumnSetTitle colA "Location"+ treeViewColumnSetSizing colA TreeViewColumnAutosize+ treeViewColumnSetResizable colA True+ treeViewColumnSetReorderable colA True+ treeViewAppendColumn treeView colA+ cellLayoutPackStart colA rendererA False+ cellLayoutSetAttributes colA rendererA errorStore+ $ \row -> [cellText := if index row == 0 then showSourceSpan (logRef row) else "",+ cellTextForeground := if (logRefType (logRef row)) == WarningRef+ then "green"+ else "red" ]+ rendererB <- cellRendererTextNew+ colB <- treeViewColumnNew+ treeViewColumnSetTitle colB "Description"+ treeViewColumnSetSizing colB TreeViewColumnAutosize+ treeViewColumnSetResizable colB True+ treeViewColumnSetReorderable colB True+ treeViewAppendColumn treeView colB+ cellLayoutPackStart colB rendererB False+ cellLayoutSetAttributes colB rendererB errorStore+ $ \row -> [ cellText := string row]++ treeViewSetHeadersVisible treeView True+ selB <- treeViewGetSelection treeView+ treeSelectionSetMode selB SelectionSingle+ scrolledView <- scrolledWindowNew Nothing Nothing+ containerAdd scrolledView treeView+ scrolledWindowSetPolicy scrolledView PolicyAutomatic PolicyAutomatic+ let pane = IDEErrors scrolledView treeView errorStore+ treeView `onButtonPress` (errorViewPopup ideR errorStore treeView)+ cid1 <- treeView `afterFocusIn`+ (\_ -> do reflectIDE (makeActive pane) ideR ; return True)+ return (pane,[ConnectC cid1])++fillErrorList :: IDEAction+fillErrorList = do+ mbErrors <- getPane+ case mbErrors of+ Nothing -> return ()+ Just pane -> do+ refs <- readIDE errorRefs+ liftIO $ do+ treeStoreClear (errorStore pane)+ mapM_ (insertError (errorStore pane)) (zip refs [0..length refs])+ where+ insertError treeStore (lr,index) =+ case {--lines--} [refDescription lr] of+ [] -> treeStoreInsert treeStore [] index (ErrColumn lr "" 0)+ h:t -> do+ treeStoreInsert treeStore [] index (ErrColumn lr h 0)+ mapM_ (\(line,subind) ->+ treeStoreInsert treeStore [index] subind (ErrColumn lr line (subind + 1)))+ (zip t [0..length t])++getSelectedError :: TreeView+ -> TreeStore ErrColumn+ -> IO (Maybe LogRef)+getSelectedError treeView treeStore = do+ treeSelection <- treeViewGetSelection treeView+ paths <- treeSelectionGetSelectedRows treeSelection+ case paths of+ a:r -> do+ val <- treeStoreGetValue treeStore a+ return (Just (logRef val))+ _ -> return Nothing++selectError :: Maybe LogRef -> IDEAction+selectError mbLogRef = do+ errorRefs' <- readIDE errorRefs+ errors <- getErrors+ liftIO $ do+ selection <- treeViewGetSelection (treeView errors)+ case mbLogRef of+ Nothing -> treeSelectionUnselectAll selection+ Just lr -> case lr `elemIndex` errorRefs' of+ Nothing -> return ()+ Just ind -> treeSelectionSelectPath selection [ind]++errorViewPopup :: IDERef+ -> TreeStore ErrColumn+ -> TreeView+ -> Event+ -> IO Bool+errorViewPopup ideR store treeView (Button _ click _ _ _ _ button _ _)+ = do+ if button == RightButton+ then do+ mbSel <- getSelectedError treeView store+ theMenu <- menuNew+ item0 <- menuItemNewWithLabel "Add all imports"+ item0 `onActivateLeaf` do+ reflectIDE addAllImports ideR+ menuShellAppend theMenu item0+ case mbSel of+ Just sel ->+ case parseNotInScope (refDescription sel) of+ Nothing -> do+ return ()+ Just _ -> do+ item1 <- menuItemNewWithLabel "Add import"+ item1 `onActivateLeaf` do+ reflectIDE (addImport sel [] >> return()) ideR+ menuShellAppend theMenu item1+ Nothing -> return ()+ menuPopup theMenu Nothing+ widgetShowAll theMenu+ return True+ else if button == LeftButton && click == DoubleClick+ then liftIO $ do+ sel <- getSelectedError treeView store+ case sel of+ Just ref -> reflectIDE (setCurrentError (Just ref)) ideR+ otherwise -> sysMessage Normal "Error>> errorViewPopup: no selection2"+ return True+ else return False+errorViewPopup _ _ _ _ = throwIDE "errorViewPopup wrong event type"++++++
+ src/IDE/Pane/Grep.hs view
@@ -0,0 +1,224 @@+{-# OPTIONS_GHC -XDeriveDataTypeable -XMultiParamTypeClasses -XTypeSynonymInstances+ -XRecordWildCards #-}+-----------------------------------------------------------------------------+--+-- Module : IDE.Pane.Grep+-- Copyright : (c) Juergen Nicklisch-Franken, Hamish Mackenzie+-- License : GNU-GPL+--+-- Maintainer : <maintainer at leksah.org>+-- Stability : provisional+-- Portability : portable+--+-- | The pane of ide where grep results are displayed+--+-------------------------------------------------------------------------------++module IDE.Pane.Grep (+ IDEGrep(..)+, showGrep+, setGrepResults+, GrepState(..)+) where++import Graphics.UI.Gtk hiding (get)+import Text.ParserCombinators.Parsec.Language+import Text.ParserCombinators.Parsec hiding(Parser)+import qualified Text.ParserCombinators.Parsec.Token as P+import Data.Maybe+import Control.Monad.Reader+import Data.Typeable+import IDE.Core.State+import IDE.Tool (ToolOutput(..))+import Control.Concurrent (forkIO)+import IDE.LogRef (logOutput)+import IDE.Pane.SourceBuffer+ (goToSourceDefinition)++data GrepRecord = GrepRecord {+ file :: FilePath+, line :: Int+, context :: String+}++-- | A grep pane description+--++data IDEGrep = IDEGrep {+ scrolledView :: ScrolledWindow+, treeView :: TreeView+, grepStore :: ListStore GrepRecord+} deriving Typeable++data GrepState = GrepState+ deriving(Eq,Ord,Read,Show,Typeable)++instance IDEObject IDEGrep++instance Pane IDEGrep IDEM+ where+ primPaneName _ = "Grep"+ getAddedIndex _ = 0+ getTopWidget = castToWidget . scrolledView+ paneId b = "*Grep"+ makeActive p = activatePane p []+ close = closePane++instance RecoverablePane IDEGrep GrepState IDEM where+ saveState p = do+ return (Just GrepState)+ recoverState pp GrepState = do+ nb <- getNotebook pp+ newPane pp nb builder+ return ()++showGrep :: IDEAction+showGrep = do+ m <- getGrep+ liftIO $ bringPaneToFront m+ liftIO $ widgetGrabFocus (treeView m)++getGrep :: IDEM IDEGrep+getGrep = do+ mbGrep <- getPane+ case mbGrep of+ Just m -> return m+ Nothing -> do+ pp <- getBestPathForId "*Grep"+ nb <- getNotebook pp+ newPane pp nb builder+ mbGrep <- getPane+ case mbGrep of+ Nothing -> throwIDE "Can't init grep"+ Just m -> return m++builder :: PanePath ->+ Notebook ->+ Window ->+ IDERef ->+ IO (IDEGrep,Connections)+builder pp nb windows ideR = do+ listStore <- listStoreNew []+ treeView <- treeViewNew+ treeViewSetModel treeView listStore++ renderer1 <- cellRendererTextNew+ renderer10 <- cellRendererPixbufNew+ col1 <- treeViewColumnNew+ treeViewColumnSetTitle col1 "File"+ 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 := file row]++ renderer2 <- cellRendererTextNew+ col2 <- treeViewColumnNew+ treeViewColumnSetTitle col2 "Line"+ treeViewColumnSetSizing col2 TreeViewColumnAutosize+ treeViewColumnSetResizable col2 True+ treeViewColumnSetReorderable col2 True+ treeViewAppendColumn treeView col2+ cellLayoutPackStart col2 renderer2 True+ cellLayoutSetAttributes col2 renderer2 listStore+ $ \row -> [ cellText := show $ line row]++ renderer3 <- cellRendererTextNew+ renderer30 <- cellRendererPixbufNew+ col3 <- treeViewColumnNew+ treeViewColumnSetTitle col3 "Context"+ 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 := context row]+++ treeViewSetHeadersVisible treeView True+ sel <- treeViewGetSelection treeView+ treeSelectionSetMode sel SelectionSingle++ sw <- scrolledWindowNew Nothing Nothing+ containerAdd sw treeView+ scrolledWindowSetPolicy sw PolicyAutomatic PolicyAutomatic++ let grep = IDEGrep sw treeView listStore++ cid1 <- treeView `afterFocusIn`+ (\_ -> do reflectIDE (makeActive grep) ideR ; return True)+ sel `onSelectionChanged` do+ sel <- getSelectionGrepRecord treeView listStore+ case sel of+ Just record -> reflectIDE (do+ goToSourceDefinition (file record)+ $ Just $ Location (line record) 0 (line record) 0) ideR+ Nothing -> return ()++ return (grep,[ConnectC cid1])++grepLineParser :: CharParser () GrepRecord+grepLineParser = try (do+ file <- many (noneOf ":")+ char ':'+ line <- int+ char ':'+ context <- many anyChar+ return $ GrepRecord {..}+ <?> "grepLineParser")++lexer = P.makeTokenParser emptyDef+lexeme = P.lexeme lexer+whiteSpace = P.whiteSpace lexer+hexadecimal = P.hexadecimal lexer+symbol = P.symbol lexer+identifier = P.identifier lexer+colon = P.colon lexer+int = fmap fromInteger $ P.integer lexer++getSelectionGrepRecord :: TreeView+ -> ListStore GrepRecord+ -> IO (Maybe GrepRecord)+getSelectionGrepRecord treeView listStore = do+ treeSelection <- treeViewGetSelection treeView+ paths <- treeSelectionGetSelectedRows treeSelection+ case paths of+ [a]:r -> do+ size <- listStoreGetSize listStore+ if a < size+ then fmap Just $ listStoreGetValue listStore a+ else return Nothing+ _ -> return Nothing++setGrepResults :: [ToolOutput] -> IDEAction+setGrepResults output = do+ grep <- getGrep+ ideRef <- ask+ liftIO $ do+ let (displayed, dropped) = splitAt 10000 output+ bringPaneToFront grep+ forkIO $ do+ let errors = filter (isNothing . process) output+ ++ if null dropped+ then []+ else [ToolError $ "Dropped " ++ show (length dropped) ++ " search results"]+ unless (null errors) $ reflectIDE (logOutput errors) ideRef+ return ()+ postGUIAsync $ listStoreClear (grepStore grep)+ forM_ (catMaybes (map process displayed)) $ \record -> do+ postGUIAsync $ do+ listStoreAppend (grepStore grep) record+ return ()+ where+ process (ToolOutput line) =+ case parse grepLineParser "" line of+ Right record -> Just record+ _ -> Nothing+ process _ = Nothing++
src/IDE/Pane/Info.hs view
@@ -24,7 +24,6 @@ ) where import Graphics.UI.Gtk hiding (afterToggleOverwrite)-import Control.Monad.Reader import Control.Monad import Control.Monad.Trans import Data.Maybe@@ -32,7 +31,6 @@ import Data.Typeable import IDE.Core.State-import Control.Event import IDE.Pane.SourceBuffer import IDE.Pane.References import IDE.FileUtils (openBrowser)@@ -68,7 +66,10 @@ currentDescr' <- liftIO $ readIORef (currentDescr p) return (Just (InfoState currentDescr')) recoverState pp (InfoState descr) = do- setInfo descr+ nb <- getNotebook pp+ prefs <- readIDE prefs+ newPane pp nb (builder descr prefs)+ return () showInfo :: IDEAction showInfo = do@@ -77,99 +78,95 @@ Nothing -> return () Just p -> liftIO $ bringPaneToFront p --initInfo :: PanePath -> Notebook -> Descr -> IDEAction-initInfo panePath nb idDescr = do- panes <- readIDE panes- paneMap <- readIDE paneMap- prefs <- readIDE prefs- (pane,cids) <- reifyIDE $ \ideR -> do- ibox <- vBoxNew False 0- -- Buttons- bb <- hButtonBoxNew- buttonBoxSetLayout bb ButtonboxSpread- definitionB <- buttonNewWithLabel "Source"- moduB <- buttonNewWithLabel "Modules"- usesB <- buttonNewWithLabel "Refs"- docuB <- buttonNewWithLabel "Docu"- searchB <- buttonNewWithLabel "Search"- boxPackStartDefaults bb definitionB- boxPackStartDefaults bb moduB- boxPackStartDefaults bb usesB- boxPackStartDefaults bb docuB- boxPackStartDefaults bb searchB- -- Descr View- font <- case textviewFont prefs of- Just str -> do- fontDescriptionFromString str- Nothing -> do- f <- fontDescriptionNew- fontDescriptionSetFamily f "Monospace"- return f+builder :: Descr ->+ Prefs ->+ PanePath ->+ Notebook ->+ Window ->+ IDERef ->+ IO (IDEInfo,Connections)+builder idDescr prefs pp nb windows ideR = do+ ibox <- vBoxNew False 0+-- Buttons+ bb <- hButtonBoxNew+ buttonBoxSetLayout bb ButtonboxSpread+ definitionB <- buttonNewWithLabel "Source"+ moduB <- buttonNewWithLabel "Modules"+ usesB <- buttonNewWithLabel "Refs"+ docuB <- buttonNewWithLabel "Docu"+ searchB <- buttonNewWithLabel "Search"+ boxPackStartDefaults bb definitionB+ boxPackStartDefaults bb moduB+ boxPackStartDefaults bb usesB+ boxPackStartDefaults bb docuB+ boxPackStartDefaults bb searchB+-- Descr View+ font <- case textviewFont prefs of+ Just str -> do+ fontDescriptionFromString str+ Nothing -> do+ f <- fontDescriptionNew+ fontDescriptionSetFamily f "Monospace"+ return f - descriptionView <- sourceViewNew- descriptionBuffer <- (get descriptionView textViewBuffer) >>= (return . castToSourceBuffer)- lm <- sourceLanguageManagerNew- mbLang <- sourceLanguageManagerGuessLanguage lm Nothing (Just "text/x-haskell")- case mbLang of- Nothing -> return ()- Just lang -> do sourceBufferSetLanguage descriptionBuffer lang+ descriptionView <- sourceViewNew+ descriptionBuffer <- (get descriptionView textViewBuffer) >>= (return . castToSourceBuffer)+ lm <- sourceLanguageManagerNew+ mbLang <- sourceLanguageManagerGuessLanguage lm Nothing (Just "text/x-haskell")+ case mbLang of+ Nothing -> return ()+ Just lang -> do sourceBufferSetLanguage descriptionBuffer lang - -- This call is here because in the past I have had problems where the- -- language object became invalid if the manager was garbage collected- sourceLanguageManagerGetLanguageIds lm+ -- This call is here because in the past I have had problems where the+ -- language object became invalid if the manager was garbage collected+ sourceLanguageManagerGetLanguageIds lm - sourceBufferSetHighlightSyntax descriptionBuffer True- widgetModifyFont descriptionView (Just font)+ 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+ 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+ sw <- scrolledWindowNew Nothing Nothing+ containerAdd sw descriptionView+ scrolledWindowSetPolicy sw PolicyAutomatic PolicyAutomatic - boxPackStart ibox sw PackGrow 10- boxPackEnd ibox bb PackNatural 10+ boxPackStart ibox sw PackGrow 10+ boxPackEnd ibox bb PackNatural 10 - --openType- currentDescr' <- newIORef idDescr- let info = IDEInfo ibox currentDescr' descriptionView- definitionB `onClicked` (reflectIDE gotoSource ideR )- moduB `onClicked` (reflectIDE gotoModule' ideR )- usesB `onClicked` (reflectIDE referencedFrom' ideR )- searchB `onClicked` (do- descr <- readIORef currentDescr'- reflectIDE (do- triggerEvent ideR (SearchMeta (descrName descr))- showInfo) ideR )- docuB `onClicked` (do- descr <- readIORef currentDescr'- reflectIDE (openBrowser $ docuSearchURL prefs ++ descrName descr) ideR)- descriptionView `widgetAddEvents` [ButtonReleaseMask]- id5 <- descriptionView `onButtonRelease`- (\ e -> do- buf <- textViewGetBuffer descriptionView- (l,r) <- textBufferGetSelectionBounds buf- symbol <- textBufferGetText buf l r True- when (controlIsPressed e)- (reflectIDE (do- triggerEvent ideR (SelectInfo symbol)- return ()) ideR)- return False)- notebookInsertOrdered nb ibox (paneName info) Nothing- widgetShowAll ibox- return (info,[])- addPaneAdmin pane [] panePath- liftIO $widgetGrabFocus (sw pane)- liftIO $bringPaneToFront pane+ --openType+ currentDescr' <- newIORef idDescr+ let info = IDEInfo ibox currentDescr' descriptionView+ definitionB `onClicked` (reflectIDE gotoSource ideR )+ moduB `onClicked` (reflectIDE gotoModule' ideR )+ usesB `onClicked` (reflectIDE referencedFrom' ideR )+ searchB `onClicked` (do+ descr <- readIORef currentDescr'+ reflectIDE (do+ triggerEventIDE (SearchMeta (descrName descr))+ showInfo) ideR )+ docuB `onClicked` (do+ descr <- readIORef currentDescr'+ reflectIDE (openBrowser $ docuSearchURL prefs ++ descrName descr) ideR)+ descriptionView `widgetAddEvents` [ButtonReleaseMask]+ id5 <- descriptionView `onButtonRelease`+ (\ e -> do+ buf <- textViewGetBuffer descriptionView+ (l,r) <- textBufferGetSelectionBounds buf+ symbol <- textBufferGetText buf l r True+ when (controlIsPressed e)+ (reflectIDE (do+ triggerEventIDE (SelectInfo symbol)+ return ()) ideR)+ return False)+ return (info,[]) gotoSource :: IDEAction gotoSource = do@@ -182,10 +179,9 @@ gotoModule' :: IDEAction gotoModule' = do mbInfo <- getInfoCont- ideR <- ask case mbInfo of Nothing -> return ()- Just info -> triggerEvent ideR (SelectIdent info) >> return ()+ Just info -> triggerEventIDE (SelectIdent info) >> return () referencedFrom' :: IDEAction referencedFrom' = do@@ -196,7 +192,6 @@ setSymbol :: String -> IDEAction setSymbol symbol = do- ideR <- ask currentInfo' <- readIDE currentInfo case currentInfo' of Nothing -> return ()@@ -207,8 +202,8 @@ setInfo a showInfo if length (a:r) > 1- then triggerEvent ideR (DescrChoice (a:r)) >> return ()- else triggerEvent ideR (SelectIdent a) >> return ()+ then triggerEventIDE (DescrChoice (a:r)) >> return ()+ else triggerEventIDE (SelectIdent a) >> return () setInfo :: Descr -> IDEAction@@ -216,11 +211,11 @@ mbPane <- getPane case mbPane of Nothing -> do- prefs <- readIDE prefs- layout <- readIDE layout- let pp = getStandardPanePath (logPanePath prefs) layout+ pp <- getBestPathForId "*Info" nb <- getNotebook pp- initInfo pp nb identifierDescr+ prefs <- readIDE prefs+ newPane pp nb (builder identifierDescr prefs)+ return () Just info -> do oldDescr <- liftIO $ readIORef (currentDescr info) liftIO $ do@@ -241,8 +236,7 @@ recordInfoHistory :: Descr -> Descr -> IDEAction recordInfoHistory descr oldDescr = do- ideR <- ask- triggerEvent ideR (RecordHistory+ triggerEventIDE (RecordHistory ((InfoElementSelected descr), (InfoElementSelected oldDescr))) return ()
src/IDE/Pane/Log.hs view
@@ -31,7 +31,7 @@ import Graphics.UI.Gtk import Graphics.UI.Gtk.Gdk.Events import Control.Monad.Trans (liftIO)-import IDE.Pane.SourceBuffer (markErrorInSourceBuf,selectSourceBuf)+import IDE.Pane.SourceBuffer (markRefInSourceBuf,selectSourceBuf) import System.IO import Prelude hiding (catch) import Control.Exception hiding (try)@@ -73,7 +73,7 @@ instance Pane IDELog IDEM where- primPaneName _ = "Log"+ primPaneName _ = "Log" getAddedIndex _ = 0 getTopWidget = castToWidget . scrolledWindowL paneId b = "*Log"@@ -84,7 +84,9 @@ saveState p = return (Just LogState) recoverState pp LogState = do nb <- getNotebook pp- initLog pp nb+ prefs' <- readIDE prefs+ newPane pp nb (builder prefs')+ return () -------------------------------------------------------------------------------@@ -93,112 +95,119 @@ -- -initLog :: PanePath -> Notebook -> IDEAction-initLog panePath nb = do- panes <- readIDE panes- paneMap <- readIDE paneMap- prefs <- readIDE prefs- (buf,cids) <- reifyIDE $ \ideR -> do- tv <- textViewNew- buf <- textViewGetBuffer tv- iter <- textBufferGetEndIter buf- textBufferCreateMark buf (Just "end") iter True+builder :: Prefs ->+ PanePath ->+ Notebook ->+ Window ->+ IDERef ->+ IO (IDELog,Connections)+builder prefs pp nb windows ideR = do+ tv <- textViewNew+ buf <- textViewGetBuffer tv+ iter <- textBufferGetEndIter buf+ textBufferCreateMark buf (Just "end") iter True - tags <- textBufferGetTagTable buf- errtag <- textTagNew (Just "err")- set errtag[textTagForeground := "red"]- textTagTableAdd tags errtag- frametag <- textTagNew (Just "frame")- set frametag[textTagForeground := "green"]- textTagTableAdd tags frametag- activeErrtag <- textTagNew (Just "activeErr")- set activeErrtag[textTagBackground := "yellow"]- textTagTableAdd tags activeErrtag+ tags <- textBufferGetTagTable buf+ errtag <- textTagNew (Just "err")+ set errtag[textTagForeground := "red"]+ textTagTableAdd tags errtag+ frametag <- textTagNew (Just "frame")+ set frametag[textTagForeground := "dark green"]+ textTagTableAdd tags frametag+ activeErrtag <- textTagNew (Just "activeErr")+ set activeErrtag[textTagBackground := "yellow"]+ textTagTableAdd tags activeErrtag+ intputTag <- textTagNew (Just "input")+ set intputTag[textTagForeground := "blue"]+ textTagTableAdd tags intputTag+ infoTag <- textTagNew (Just "info")+ set infoTag[textTagForeground := "grey"]+ textTagTableAdd tags infoTag - textViewSetEditable tv True- fd <- case logviewFont prefs of- Just str -> do- fontDescriptionFromString str- Nothing -> do- f <- fontDescriptionNew- fontDescriptionSetFamily f "Sans"- return f- widgetModifyFont tv (Just fd)- sw <- scrolledWindowNew Nothing Nothing- containerAdd sw tv- scrolledWindowSetPolicy sw PolicyAutomatic PolicyAutomatic- scrolledWindowSetShadowType sw ShadowIn+ textViewSetEditable tv False+ fd <- case logviewFont prefs of+ Just str -> do+ fontDescriptionFromString str+ Nothing -> do+ f <- fontDescriptionNew+ fontDescriptionSetFamily f "Sans"+ return f+ widgetModifyFont tv (Just fd)+ sw <- scrolledWindowNew Nothing Nothing+ containerAdd sw tv+ scrolledWindowSetPolicy sw PolicyAutomatic PolicyAutomatic+ scrolledWindowSetShadowType sw ShadowIn - let buf = IDELog tv sw- notebookInsertOrdered nb sw (paneName buf) Nothing- widgetShowAll (scrolledWindowL buf)- cid1 <- tv `afterFocusIn`- (\_ -> do reflectIDE (makeActive buf) ideR ; return True)- cid2 <- tv `onButtonPress`- (\ b -> do reflectIDE (clicked b buf) ideR ; return True)- return (buf,[ConnectC cid1, ConnectC cid2])- addPaneAdmin buf cids panePath- liftIO $widgetGrabFocus (textView buf)+ let buf = IDELog tv sw+ cid1 <- tv `afterFocusIn`+ (\_ -> do reflectIDE (makeActive buf) ideR ; return False)+ cid2 <- tv `onButtonPress`+ (\ b -> do reflectIDE (clicked b buf) ideR ; return False)+ cid3 <- tv `onPopulatePopup` (populatePopup buf ideR)+ return (buf,[ConnectC cid1, ConnectC cid2]) clicked :: Event -> IDELog -> IDEAction clicked (Button _ SingleClick _ _ _ _ LeftButton x y) ideLog = do- errors' <- readIDE errors+ logRefs' <- readIDE allLogRefs line' <- liftIO $ do (x,y) <- widgetGetPointer (textView ideLog) (_,y') <- textViewWindowToBufferCoords (textView ideLog) TextWindowWidget (x,y) (iter,_) <- textViewGetLineAtY (textView ideLog) y' textIterGetLine iter case filter (\(es,_) -> fst (logLines es) <= (line'+1) && snd (logLines es) >= (line'+1))- (zip errors' [0..(length errors')]) of- [(thisErr,n)] -> do- mbBuf <- selectSourceBuf (filePath thisErr)+ (zip logRefs' [0..(length logRefs')]) of+ [(thisRef,n)] -> do+ mbBuf <- selectSourceBuf (filePath thisRef) case mbBuf of- Just buf -> markErrorInSourceBuf n buf (line thisErr) (column thisErr)- (errDescription thisErr) True+ Just buf -> markRefInSourceBuf n buf thisRef True Nothing -> return () log :: IDELog <- getLog- liftIO $ markErrorInLog log (logLines thisErr)- modifyIDE_ (\ide -> return (ide{currentErr = Just n}))+ liftIO $ markErrorInLog log (logLines thisRef)+ case logRefType thisRef of+ BreakpointRef -> setCurrentBreak (Just thisRef)+ _ -> setCurrentError (Just thisRef) otherwise -> return ()-clicked (Button _ SingleClick _ _ _ _ RightButton x y) ideLog = do- errors' <- readIDE errors- line' <- reifyIDE $ \ideR -> do- (x,y) <- widgetGetPointer (textView ideLog)- (_,y') <- textViewWindowToBufferCoords (textView ideLog) TextWindowWidget (x,y)- (iter,_) <- textViewGetLineAtY (textView ideLog) y'- textIterGetLine iter- case filter (\(es,_) -> fst (logLines es) <= (line'+1) && snd (logLines es) >= (line'+1))- (zip errors' [0..(length errors')]) of- [(thisErr,n)] -> reifyIDE $ \ideR -> do- theMenu <- menuNew+clicked _ _ = return ()++populatePopup ideLog ideR menu = do+ items <- containerGetChildren menu+ res <- reflectIDE (do+ logRefs' <- readIDE allLogRefs+ line' <- reifyIDE $ \ideR -> do+ (x,y) <- widgetGetPointer (textView ideLog)+ (_,y') <- textViewWindowToBufferCoords (textView ideLog) TextWindowWidget (x,y)+ (iter,_) <- textViewGetLineAtY (textView ideLog) y'+ textIterGetLine iter+ return $ filter (\(es,_) -> fst (logLines es) <= (line'+1) && snd (logLines es) >= (line'+1))+ (zip logRefs' [0..(length logRefs')])) ideR+ case res of+ [(thisRef,n)] -> do item0 <- menuItemNewWithLabel "Add all imports" item0 `onActivateLeaf` do reflectIDE addAllImports ideR- menuShellAppend theMenu item0- case parseNotInScope (errDescription thisErr) of+ menuShellAppend menu item0+ case parseNotInScope (refDescription thisRef) of Nothing -> do return () Just _ -> do item1 <- menuItemNewWithLabel "Add import" item1 `onActivateLeaf` do- reflectIDE (addImport thisErr [] >> return()) ideR- menuShellAppend theMenu item1- menuPopup theMenu Nothing- widgetShowAll theMenu+ reflectIDE (addImport thisRef [] >> return()) ideR+ menuShellAppend menu item1+ widgetShowAll menu return () otherwise -> return ()-clicked _ _ = return ()+ mapM_ widgetHide $ take 2 (reverse items) getLog' :: IDEM IDELog getLog' = do mbPane <- getPane case mbPane of Nothing -> do- prefs <- readIDE prefs- layout <- readIDE layout- let pp = getStandardPanePath (logPanePath prefs) layout+ pp <- getBestPathForId "*Log" nb <- getNotebook pp- initLog pp nb+ prefs' <- readIDE prefs+ newPane pp nb (builder prefs') mbPane <- getPane case mbPane of Nothing -> throwIDE "Can't init log"@@ -218,23 +227,26 @@ textBufferSelectRange buf iter iter textBufferInsert buf iter string iter2 <- textBufferGetEndIter buf- case tag of- LogTag -> return ()- ErrorTag -> do- len <- textBufferGetCharCount buf- strti <- textBufferGetIterAtOffset buf (len - length string)- textBufferApplyTagByName buf "err" iter2 strti- FrameTag -> do+ let tagName = case tag of+ LogTag -> Nothing+ ErrorTag -> Just "err"+ FrameTag -> Just "frame"+ InputTag -> Just "input"+ InfoTag -> Just "info"++ case tagName of+ Nothing -> return ()+ Just name -> do len <- textBufferGetCharCount buf strti <- textBufferGetIterAtOffset buf (len - length string)- textBufferApplyTagByName buf "frame" iter2 strti+ textBufferApplyTagByName buf name iter2 strti+ textBufferMoveMarkByName buf "end" iter2 mbMark <- textBufferGetMark buf "end" line <- textIterGetLine iter2 case mbMark of Nothing -> return () Just mark -> textViewScrollMarkOnscreen tv mark- bringPaneToFront l return line markErrorInLog' :: IDELog -> (Int,Int) -> IO ()@@ -260,7 +272,9 @@ log <- getLog buf <- liftIO$ textViewGetBuffer $textView log liftIO $textBufferSetText buf ""- modifyIDE_ (\ide -> return (ide{errors = [], currentErr = Nothing}))+-- modifyIDE_ (\ide -> ide{allLogRefs = []})+-- setCurrentError Nothing+-- setCurrentBreak Nothing TODO: Check with Hamish
src/IDE/Pane/Modules.hs view
@@ -136,7 +136,8 @@ return (Just (ModulesState i sc mbs expander)) recoverState pp (ModulesState i sc@(scope,useBlacklist) se exp) = do nb <- getNotebook pp- initModules pp nb+ ci <- readIDE currentInfo+ newPane pp nb (builder ci) mod <- getModules liftIO $ writeIORef (expanderState mod) exp case scope of@@ -148,8 +149,7 @@ fillModulesList sc selectNames se applyExpanderState--+ return () selectIdentifier :: Descr -> IDEAction selectIdentifier idDescr = do@@ -248,161 +248,155 @@ mbMod <- getPane case mbMod of Nothing -> do- prefs <- readIDE prefs- layout <- readIDE layout- let pp = getStandardPanePath (modulesPanePath prefs) layout+ pp <- getBestPathForId "*Modules" nb <- getNotebook pp- initModules pp nb+ ci <- readIDE currentInfo+ newPane pp nb (builder ci) mbMod <- getPane case mbMod of Nothing -> throwIDE "Can't init modules" Just m -> return m Just m -> return m -initModules :: PanePath -> Notebook -> IDEAction-initModules panePath nb = do- panes <- readIDE panes- paneMap <- readIDE paneMap- prefs <- readIDE prefs- currentInfo <- readIDE currentInfo- (buf,cids) <- reifyIDE $ \ideR -> do--- Modules List- let forest = case currentInfo of- Nothing -> []- Just pair -> subForest (buildModulesTree pair)- treeStore <- treeStoreNew forest- treeView <- treeViewNew- treeViewSetModel treeView treeStore- --treeViewSetRulesHint treeView True+builder :: Maybe (PackageScope, PackageScope) ->+ PanePath ->+ Notebook ->+ Window ->+ IDERef ->+ IO (IDEModules,Connections)+builder currentInfo pp nb windows ideR = do+ let forest = case currentInfo of+ Nothing -> []+ Just pair -> subForest (buildModulesTree pair)+ treeStore <- treeStoreNew forest+ treeView <- treeViewNew+ treeViewSetModel treeView treeStore+ --treeViewSetRulesHint treeView True - renderer0 <- cellRendererPixbufNew- set renderer0 [ cellPixbufStockId := "" ]+ renderer0 <- cellRendererPixbufNew+ set renderer0 [ cellPixbufStockId := "" ] - renderer <- cellRendererTextNew- col <- treeViewColumnNew- treeViewColumnSetTitle col "Modules"- treeViewColumnSetSizing col TreeViewColumnAutosize- treeViewColumnSetResizable col True- treeViewColumnSetReorderable col True- treeViewAppendColumn treeView col- cellLayoutPackStart col renderer0 False- cellLayoutPackStart col renderer True- cellLayoutSetAttributes col renderer treeStore- $ \row -> [ cellText := fst row]- cellLayoutSetAttributes col renderer0 treeStore- $ \row -> [- cellPixbufStockId :=- if null (snd row)- then ""- else if isJust (mbSourcePathMD (fst (head (snd row))))- then "ide_source"- else ""]+ renderer <- cellRendererTextNew+ col <- treeViewColumnNew+ treeViewColumnSetTitle col "Modules"+ treeViewColumnSetSizing col TreeViewColumnAutosize+ treeViewColumnSetResizable col True+ treeViewColumnSetReorderable col True+ treeViewAppendColumn treeView col+ cellLayoutPackStart col renderer0 False+ cellLayoutPackStart col renderer True+ cellLayoutSetAttributes col renderer treeStore+ $ \row -> [ cellText := fst row]+ cellLayoutSetAttributes col renderer0 treeStore+ $ \row -> [+ cellPixbufStockId :=+ if null (snd row)+ then ""+ else if isJust (mbSourcePathMD (fst (head (snd row))))+ then "ide_source"+ else ""] - renderer2 <- cellRendererTextNew- col2 <- treeViewColumnNew- treeViewColumnSetTitle col2 "Packages"- treeViewColumnSetSizing col2 TreeViewColumnAutosize- treeViewColumnSetResizable col2 True- treeViewColumnSetReorderable col2 True- treeViewAppendColumn treeView col2- cellLayoutPackStart col2 renderer2 True- cellLayoutSetAttributes col2 renderer2 treeStore- $ \row -> [ cellText := (concat . intersperse ", ")- $ map (display . packagePD . snd) (snd row)]- treeViewSetHeadersVisible treeView True- treeViewSetEnableSearch treeView True- treeViewSetSearchEqualFunc treeView (Just (treeViewSearch treeView treeStore))+ renderer2 <- cellRendererTextNew+ col2 <- treeViewColumnNew+ treeViewColumnSetTitle col2 "Packages"+ treeViewColumnSetSizing col2 TreeViewColumnAutosize+ treeViewColumnSetResizable col2 True+ treeViewColumnSetReorderable col2 True+ treeViewAppendColumn treeView col2+ cellLayoutPackStart col2 renderer2 True+ cellLayoutSetAttributes col2 renderer2 treeStore+ $ \row -> [ cellText := (concat . intersperse ", ")+ $ map (display . packagePD . snd) (snd row)]+ treeViewSetHeadersVisible treeView True+ treeViewSetEnableSearch treeView True+ treeViewSetSearchEqualFunc treeView (Just (treeViewSearch treeView treeStore)) -- Facet view - descrView <- treeViewNew- descrStore <- treeStoreNew []- treeViewSetModel descrView descrStore- renderer30 <- cellRendererPixbufNew- renderer31 <- cellRendererPixbufNew- renderer3 <- cellRendererTextNew- col <- treeViewColumnNew- treeViewColumnSetTitle col "Interface"- --treeViewColumnSetSizing col TreeViewColumnAutosize- treeViewAppendColumn descrView col- cellLayoutPackStart col renderer30 False- cellLayoutPackStart col renderer31 False- cellLayoutPackStart col renderer3 True- cellLayoutSetAttributes col renderer3 descrStore- $ \row -> [ cellText := descrTreeText row]- cellLayoutSetAttributes col renderer30 descrStore- $ \row -> [- cellPixbufStockId := stockIdFromType (descrIdType row)]- cellLayoutSetAttributes col renderer31 descrStore- $ \row -> [- cellPixbufStockId := if isReexported row- then "ide_reexported"- else if isJust (mbLocation row)- then "ide_source"- else ""]- treeViewSetHeadersVisible descrView True- treeViewSetEnableSearch descrView True- treeViewSetSearchEqualFunc descrView (Just (descrViewSearch descrView descrStore))- pane' <- hPanedNew- sw <- scrolledWindowNew Nothing Nothing- containerAdd sw treeView- scrolledWindowSetPolicy sw PolicyAutomatic PolicyAutomatic- sw2 <- scrolledWindowNew Nothing Nothing- containerAdd sw2 descrView- scrolledWindowSetPolicy sw2 PolicyAutomatic PolicyAutomatic- panedAdd1 pane' sw- panedAdd2 pane' sw2- (x,y) <- widgetGetSize nb- panedSetPosition pane' (x `quot` 2)- box <- hBoxNew True 2- rb1 <- radioButtonNewWithLabel "Local"- rb2 <- radioButtonNewWithLabelFromWidget rb1 "Package"- rb3 <- radioButtonNewWithLabelFromWidget rb1 "System"- toggleButtonSetActive rb3 True- cb <- checkButtonNewWithLabel "Blacklist"+ descrView <- treeViewNew+ descrStore <- treeStoreNew []+ treeViewSetModel descrView descrStore+ renderer30 <- cellRendererPixbufNew+ renderer31 <- cellRendererPixbufNew+ renderer3 <- cellRendererTextNew+ col <- treeViewColumnNew+ treeViewColumnSetTitle col "Interface"+ --treeViewColumnSetSizing col TreeViewColumnAutosize+ treeViewAppendColumn descrView col+ cellLayoutPackStart col renderer30 False+ cellLayoutPackStart col renderer31 False+ cellLayoutPackStart col renderer3 True+ cellLayoutSetAttributes col renderer3 descrStore+ $ \row -> [ cellText := descrTreeText row]+ cellLayoutSetAttributes col renderer30 descrStore+ $ \row -> [+ cellPixbufStockId := stockIdFromType (descrIdType row)]+ cellLayoutSetAttributes col renderer31 descrStore+ $ \row -> [+ cellPixbufStockId := if isReexported row+ then "ide_reexported"+ else if isJust (mbLocation row)+ then "ide_source"+ else ""]+ treeViewSetHeadersVisible descrView True+ treeViewSetEnableSearch descrView True+ treeViewSetSearchEqualFunc descrView (Just (descrViewSearch descrView descrStore))+ pane' <- hPanedNew+ sw <- scrolledWindowNew Nothing Nothing+ containerAdd sw treeView+ scrolledWindowSetPolicy sw PolicyAutomatic PolicyAutomatic+ sw2 <- scrolledWindowNew Nothing Nothing+ containerAdd sw2 descrView+ scrolledWindowSetPolicy sw2 PolicyAutomatic PolicyAutomatic+ panedAdd1 pane' sw+ panedAdd2 pane' sw2+ (x,y) <- widgetGetSize nb+ panedSetPosition pane' (x `quot` 2)+ box <- hBoxNew True 2+ rb1 <- radioButtonNewWithLabel "Local"+ rb2 <- radioButtonNewWithLabelFromWidget rb1 "Package"+ rb3 <- radioButtonNewWithLabelFromWidget rb1 "System"+ toggleButtonSetActive rb3 True+ cb <- checkButtonNewWithLabel "Blacklist" - boxPackStart box rb1 PackGrow 2- boxPackStart box rb2 PackGrow 2- boxPackStart box rb3 PackGrow 2- boxPackEnd box cb PackNatural 2+ boxPackStart box rb1 PackGrow 2+ boxPackStart box rb2 PackGrow 2+ boxPackStart box rb3 PackGrow 2+ boxPackEnd box cb PackNatural 2 - boxOuter <- vBoxNew False 2- boxPackStart boxOuter box PackNatural 2- boxPackStart boxOuter pane' PackGrow 2- oldState <- liftIO $ newIORef $ SelectionState Nothing Nothing System False- expanderState <- liftIO $ newIORef emptyExpansion- scopeRef <- newIORef (System,True)- let modules = IDEModules boxOuter pane' treeView treeStore descrView descrStore- rb1 rb2 rb3 cb oldState expanderState- notebookInsertOrdered nb boxOuter (paneName modules) Nothing- widgetShowAll boxOuter- cid3 <- treeView `onRowActivated`- (\ treePath _ -> do- treeViewExpandRow treeView treePath False- return ())- cid1 <- treeView `afterFocusIn`- (\_ -> do reflectIDE (makeActive modules) ideR; return True)- cid2 <- descrView `afterFocusIn`- (\_ -> do reflectIDE (makeActive modules) ideR; return True)- treeView `onButtonPress` (treeViewPopup ideR treeStore treeView)- descrView `onButtonPress` (descrViewPopup ideR descrStore descrView)- rb1 `onToggled` (reflectIDE scopeSelection ideR)- rb2 `onToggled` (reflectIDE scopeSelection ideR)- rb3 `onToggled` (reflectIDE scopeSelection ideR)- cb `onToggled` (reflectIDE scopeSelection ideR)- sel <- treeViewGetSelection treeView- sel `onSelectionChanged` do- fillFacets treeView treeStore descrView descrStore- reflectIDE recordSelHistory ideR- return ()- sel2 <- treeViewGetSelection descrView- sel2 `onSelectionChanged` do- fillInfo descrView descrStore ideR- reflectIDE recordSelHistory ideR- return ()- return (modules,[ConnectC cid1,ConnectC cid2, ConnectC cid3])- addPaneAdmin buf cids panePath- liftIO $widgetGrabFocus (paned buf)+ boxOuter <- vBoxNew False 2+ boxPackStart boxOuter box PackNatural 2+ boxPackStart boxOuter pane' PackGrow 2+ oldState <- liftIO $ newIORef $ SelectionState Nothing Nothing System False+ expanderState <- liftIO $ newIORef emptyExpansion+ scopeRef <- newIORef (System,True)+ let modules = IDEModules boxOuter pane' treeView treeStore descrView descrStore+ rb1 rb2 rb3 cb oldState expanderState+ cid3 <- treeView `onRowActivated`+ (\ treePath _ -> do+ treeViewExpandRow treeView treePath False+ return ())+ cid1 <- treeView `afterFocusIn`+ (\_ -> do reflectIDE (makeActive modules) ideR; return True)+ cid2 <- descrView `afterFocusIn`+ (\_ -> do reflectIDE (makeActive modules) ideR; return True)+ treeView `onButtonPress` (treeViewPopup ideR treeStore treeView)+ descrView `onButtonPress` (descrViewPopup ideR descrStore descrView)+ rb1 `onToggled` (reflectIDE scopeSelection ideR)+ rb2 `onToggled` (reflectIDE scopeSelection ideR)+ rb3 `onToggled` (reflectIDE scopeSelection ideR)+ cb `onToggled` (reflectIDE scopeSelection ideR)+ sel <- treeViewGetSelection treeView+ sel `onSelectionChanged` do+ fillFacets treeView treeStore descrView descrStore+ reflectIDE recordSelHistory ideR+ return ()+ sel2 <- treeViewGetSelection descrView+ sel2 `onSelectionChanged` do+ fillInfo descrView descrStore ideR+ reflectIDE recordSelHistory ideR+ return ()+ return (modules,[ConnectC cid1,ConnectC cid2, ConnectC cid3]) treeViewSearch :: TreeView -> TreeStore (String, [(ModuleDescr,PackageDescr)])@@ -958,12 +952,13 @@ mbPD <- getPackageDescriptionAndPath case mbPD of Nothing -> ideMessage Normal "No package description"- Just (pd,cabalPath) -> let srcPaths = concatMap hsSourceDirs $ allBuildInfo pd+ Just (pd,cabalPath) -> let srcPaths = nub $ concatMap hsSourceDirs $ allBuildInfo pd rootPath = dropFileName cabalPath modPath = foldr (\a b -> a ++ "." ++ b) "" (map fst categories) in do- mbResp <- liftIO $ addModuleDialog modPath srcPaths+ window' <- getMainWindow+ mbResp <- liftIO $ addModuleDialog window' modPath srcPaths case mbResp of Nothing -> return () Just (AddModule modPath srcPath isExposed) ->@@ -988,9 +983,10 @@ data AddModule = AddModule {moduleName :: String, sourceRoot :: FilePath, isExposed :: Bool} -addModuleDialog :: String -> [String] -> IO (Maybe AddModule)-addModuleDialog modString sourceRoots = do+addModuleDialog :: Window -> String -> [String] -> IO (Maybe AddModule)+addModuleDialog parent modString sourceRoots = do dia <- dialogNew+ windowSetTransientFor dia parent windowSetTitle dia "Construct new module" upper <- dialogGetUpper dia lower <- dialogGetActionArea dia@@ -1115,7 +1111,7 @@ Nothing -> Nothing Just descr -> Just (descrName descr) oldSel <- liftIO $ readIORef (oldSelection mods)- triggerEvent ideR (RecordHistory ((ModuleSelected selMod selFacet),+ triggerEventIDE (RecordHistory ((ModuleSelected selMod selFacet), (ModuleSelected (moduleS' oldSel) (facetS' oldSel)))) liftIO $ writeIORef (oldSelection mods) (oldSel{moduleS'= selMod, facetS' = selFacet}) return ()@@ -1134,7 +1130,7 @@ ideR <- ask mods <- getModules oldSel <- liftIO $ readIORef (oldSelection mods)- triggerEvent ideR (RecordHistory ((ScopeSelected sc bl),+ triggerEventIDE (RecordHistory ((ScopeSelected sc bl), (ScopeSelected (scope' oldSel) (blacklist' oldSel)))) liftIO $ writeIORef (oldSelection mods) (oldSel{scope'= sc, blacklist' = bl}) return ()
src/IDE/Pane/PackageEditor.hs view
@@ -38,7 +38,7 @@ import IDE.FileUtils import Graphics.UI.Editor.MakeEditor import Distribution.PackageDescription.Parse (readPackageDescription,writePackageDescription)-import Distribution.PackageDescription.Configuration (freeVars,flattenPackageDescription)+import Distribution.PackageDescription.Configuration (flattenPackageDescription) import Distribution.ModuleName(ModuleName) import Data.Typeable (Typeable(..)) import Debug.Trace (trace)@@ -93,6 +93,7 @@ import Distribution.Version (VersionRange(..)) import Default (Default(..))+import Packages (PackageConfig(..)) -- --------------------------------------------------------------------- -- The exported stuff goes here@@ -159,8 +160,8 @@ package <- liftIO $ readPackageDescription normal (cabalFile idePackage) if hasConfigs package then do- ideMessage High ("Cabal File with configurations can't be edited with the"- ++ "Current version of the editor")+ ideMessage High ("Cabal file with configurations can't be edited with the "+ ++ "current version of the editor") return () else do editPackage (flattenPackageDescription package) dirName modules (\ _ -> return ())@@ -168,17 +169,21 @@ hasConfigs :: GenericPackageDescription -> Bool hasConfigs gpd =- let freeVars1 = case condLibrary gpd of- Nothing -> []- Just ct -> freeVars ct- freeVars2 = concatMap (freeVars . snd) (condExecutables gpd)- in trace ("freeVars " ++ show freeVars1 ++ "-" ++ show freeVars2)- $ not (null freeVars1 && null freeVars2)+ let libConds = case condLibrary gpd of+ Nothing -> False+ Just condTree -> not (null (condTreeComponents condTree))+ exeConds = foldr (\ (_,condTree) hasConfigs ->+ if hasConfigs+ then True+ else not (null (condTreeComponents condTree)))+ False (condExecutables gpd)+ in libConds || exeConds + packageNew' :: (FilePath -> IDEAction) -> IDEAction packageNew' activateAction = do- window <- readIDE window- mbDirName <- liftIO $ choosePackageDir window+ windows <- getWindows+ mbDirName <- liftIO $ choosePackageDir (head windows) case mbDirName of Nothing -> return () Just dirName -> do@@ -280,11 +285,8 @@ mbPane :: Maybe PackagePane <- getPane case mbPane of Nothing -> do- ideR <- ask- prefs <- readIDE prefs- layout <- readIDE layout- let pp = getStandardPanePath (sourcePanePath prefs) layout- nb <- getNotebook pp+ pp <- getBestPathForId "*Package"+ nb <- getNotebook pp packageInfos <- inGhc $ getInstalledPackageInfos let packageEd = toEditor packageD initPackage packagePath packageEd@@ -306,134 +308,144 @@ -> [ModuleName] -> (FilePath -> IDEAction) -> IDEM ()-initPackage packageDir packageD packageDescr panePath nb2 modules afterSaveAction = do+initPackage packageDir packageD packageDescr panePath nb modules afterSaveAction = do let fields = trace ("initPackage called " ++ packageDir) $ flattenFieldDescription packageDescr let initialPackagePath = packageDir </> (display . pkgName . package . pd) packageD ++ ".cabal" liftIO $ setCurrentDirectory packageDir- panes <- readIDE panes- window <- readIDE window- paneMap <- readIDE paneMap- currentInfo <- readIDE currentInfo packageInfos <- inGhc $ getInstalledPackageInfos- (buf,cids) <- reifyIDE $ \ideR -> do- vb <- vBoxNew False 0- let packagePane = PackagePane vb- bb <- hButtonBoxNew- restore <- buttonNewFromStock "Revert"- save <- buttonNewFromStock "gtk-save"- closeB <- buttonNewFromStock "gtk-close"- addB <- buttonNewFromStock "Add Build Info"- removeB <- buttonNewFromStock "Remove Build Info"- boxPackStart bb addB PackNatural 0- boxPackStart bb removeB PackNatural 0- boxPackStart bb restore PackNatural 0- boxPackStart bb save PackNatural 0- boxPackStart bb closeB PackNatural 0- (widget, setInj, getExt, notifier) <- buildEditor packageDescr packageD- let fieldNames = map (\fd -> case getParameterPrim paraName (parameters fd) of- Just s -> s- Nothing -> "Unnamed") fields- save `onClicked` (do- mbNewPackage' <- extractAndValidate packageD [getExt] fieldNames- case mbNewPackage' of- Nothing -> return ()- Just newPackage' -> let newPackage = fromEditor newPackage' in do- let packagePath = packageDir </> (display . pkgName . package . pd) newPackage'- ++ ".cabal"- writePackageDescription packagePath newPackage- reflectIDE (afterSaveAction packagePath) ideR)- closeB `onClicked` (do- mbNewPackage' <- extractAndValidate packageD [getExt] fieldNames- case mbNewPackage' of- Nothing -> do- md <- messageDialogNew Nothing [] MessageQuestion ButtonsYesNo- "Package does not validate. Close anyway?"- rid <- dialogRun md- widgetDestroy md- case rid of- ResponseYes -> (reflectIDE (close packagePane) ideR)- otherwise -> return ()- Just newPackage -> do- let packagePath = packageDir </> (display . pkgName . package . pd) newPackage- modified <- do- exists <- liftIO $ doesFileExist packagePath- if exists- then do- packageNow <- readPackageDescription normal packagePath- let simpleNow = flattenPackageDescription packageNow- case mbNewPackage' of- Nothing -> return True --doesn't validate, so something has changed- Just pd -> return (fromEditor pd /=- simpleNow{buildDepends = reverse (buildDepends simpleNow)})- else return False- cancel <- if modified+ newPane panePath nb (builder packageDir packageD packageDescr afterSaveAction initialPackagePath+ modules packageInfos fields)+ return ()++builder :: FilePath ->+ PackageDescriptionEd ->+ FieldDescription PackageDescriptionEd ->+ (FilePath -> IDEAction) ->+ FilePath ->+ [ModuleName] ->+ [PackageConfig] ->+ [FieldDescription PackageDescriptionEd] ->+ PanePath ->+ Notebook ->+ Window ->+ IDERef ->+ IO (PackagePane,Connections)+builder packageDir packageD packageDescr afterSaveAction initialPackagePath modules packageInfos fields+ panePath nb window ideR = do+ vb <- vBoxNew False 0+ let packagePane = PackagePane vb+ bb <- hButtonBoxNew+ restore <- buttonNewFromStock "Revert"+ save <- buttonNewFromStock "gtk-save"+ closeB <- buttonNewFromStock "gtk-close"+ addB <- buttonNewFromStock "Add Build Info"+ removeB <- buttonNewFromStock "Remove Build Info"+ boxPackStart bb addB PackNatural 0+ boxPackStart bb removeB PackNatural 0+ boxPackStart bb restore PackNatural 0+ boxPackStart bb save PackNatural 0+ boxPackStart bb closeB PackNatural 0+ (widget, setInj, getExt, notifier) <- buildEditor packageDescr packageD+ let fieldNames = map (\fd -> case getParameterPrim paraName (parameters fd) of+ Just s -> s+ Nothing -> "Unnamed") fields+ save `onClicked` (do+ mbNewPackage' <- extractAndValidate packageD [getExt] fieldNames+ case mbNewPackage' of+ Nothing -> return ()+ Just newPackage' -> let newPackage = fromEditor newPackage' in do+ let packagePath = packageDir </> (display . pkgName . package . pd) newPackage'+ ++ ".cabal"+ writePackageDescription packagePath newPackage+ reflectIDE (afterSaveAction packagePath) ideR)+ closeB `onClicked` (do+ mbNewPackage' <- extractAndValidate packageD [getExt] fieldNames+ case mbNewPackage' of+ Nothing -> do+ md <- messageDialogNew Nothing [] MessageQuestion ButtonsYesNo+ "Package does not validate. Close anyway?"+ rid <- dialogRun md+ widgetDestroy md+ case rid of+ ResponseYes -> (reflectIDE (close packagePane >> return ()) ideR)+ otherwise -> return ()+ Just newPackage -> do+ let packagePath = packageDir </> (display . pkgName . package . pd) newPackage+ modified <- do+ exists <- liftIO $ doesFileExist packagePath+ if exists then do- md <- messageDialogNew (Just window) []- MessageQuestion- ButtonsNone- ("Save changes to Cabal file: "- ++ packagePath- ++ "?")- dialogAddButton md "_Save" ResponseYes- dialogAddButton md "_Don't Save" ResponseNo- dialogAddButton md "_Cancel" ResponseCancel- resp <- dialogRun md- widgetDestroy md- case resp of- ResponseYes -> do- case mbNewPackage' of- Nothing -> return False- Just newPackage' -> let newPackage = fromEditor newPackage' in do- let PackageIdentifier (PackageName n) v = package newPackage- writePackageDescription packagePath newPackage- return False- ResponseCancel -> return True- ResponseNo -> return False- _ -> return False+ packageNow <- readPackageDescription normal packagePath+ let simpleNow = flattenPackageDescription packageNow+ case mbNewPackage' of+ Nothing -> return True --doesn't validate, so something has changed+ Just pd -> return (fromEditor pd /=+ simpleNow{buildDepends = reverse (buildDepends simpleNow)}) else return False- when (not cancel) (reflectIDE (close packagePane) ideR))- restore `onClicked` (do- package <- readPackageDescription normal initialPackagePath- setInj (toEditor (flattenPackageDescription package)))- addB `onClicked` (do- mbNewPackage' <- extractAndValidate packageD [getExt] fieldNames- case mbNewPackage' of- Nothing -> sysMessage Normal "Content doesn't validate"- Just pde -> do- reflectIDE (do- close packagePane- initPackage packageDir pde {bis = bis pde ++ [bis pde !! 0]}- (packageDD- (map IPI.package packageInfos)- packageDir- modules- (length (bis pde) + 1)- (concatMap (buildInfoD (Just packageDir) modules)- [0..length (bis pde)]))- panePath nb2 modules afterSaveAction) ideR)- removeB `onClicked` (do- mbNewPackage' <- extractAndValidate packageD [getExt] fieldNames- case mbNewPackage' of- Nothing -> sysMessage Normal "Content doesn't validate"- Just pde | length (bis pde) == 1 -> sysMessage Normal "Just one Build Info"- | otherwise -> reflectIDE (do- close packagePane- initPackage packageDir pde{bis = take (length (bis pde) - 1) (bis pde)}- (packageDD- (map IPI.package packageInfos)- packageDir- modules- (length (bis pde) - 1)- (concatMap (buildInfoD (Just packageDir) modules)- [0..length (bis pde) - 2]))- panePath nb2 modules afterSaveAction) ideR)- boxPackStart vb widget PackGrow 7- boxPackEnd vb bb PackNatural 7- widgetShowAll vb- i <- notebookInsertOrdered nb2 vb (paneName packagePane) Nothing- return (packagePane,[])- addPaneAdmin buf [] panePath- liftIO $widgetGrabFocus (packageBox buf)+ cancel <- if modified+ then do+ md <- messageDialogNew (Just window) []+ MessageQuestion+ ButtonsNone+ ("Save changes to Cabal file: "+ ++ packagePath+ ++ "?")+ dialogAddButton md "_Save" ResponseYes+ dialogAddButton md "_Don't Save" ResponseNo+ dialogAddButton md "_Cancel" ResponseCancel+ resp <- dialogRun md+ widgetDestroy md+ case resp of+ ResponseYes -> do+ case mbNewPackage' of+ Nothing -> return False+ Just newPackage' -> let newPackage = fromEditor newPackage' in do+ let PackageIdentifier (PackageName n) v = package newPackage+ writePackageDescription packagePath newPackage+ return False+ ResponseCancel -> return True+ ResponseNo -> return False+ _ -> return False+ else return False+ when (not cancel) (reflectIDE (close packagePane >> return ()) ideR))+ restore `onClicked` (do+ package <- readPackageDescription normal initialPackagePath+ setInj (toEditor (flattenPackageDescription package)))+ addB `onClicked` (do+ mbNewPackage' <- extractAndValidate packageD [getExt] fieldNames+ case mbNewPackage' of+ Nothing -> sysMessage Normal "Content doesn't validate"+ Just pde -> do+ reflectIDE (do+ close packagePane+ initPackage packageDir pde {bis = bis pde ++ [bis pde !! 0]}+ (packageDD+ (map IPI.package packageInfos)+ packageDir+ modules+ (length (bis pde) + 1)+ (concatMap (buildInfoD (Just packageDir) modules)+ [0..length (bis pde)]))+ panePath nb modules afterSaveAction) ideR)+ removeB `onClicked` (do+ mbNewPackage' <- extractAndValidate packageD [getExt] fieldNames+ case mbNewPackage' of+ Nothing -> sysMessage Normal "Content doesn't validate"+ Just pde | length (bis pde) == 1 -> sysMessage Normal "Just one Build Info"+ | otherwise -> reflectIDE (do+ close packagePane+ initPackage packageDir pde{bis = take (length (bis pde) - 1) (bis pde)}+ (packageDD+ (map IPI.package packageInfos)+ packageDir+ modules+ (length (bis pde) - 1)+ (concatMap (buildInfoD (Just packageDir) modules)+ [0..length (bis pde) - 2]))+ panePath nb modules afterSaveAction) ideR)+ boxPackStart vb widget PackGrow 7+ boxPackEnd vb bb PackNatural 7+ return (packagePane,[]) -- --------------------------------------------------------------------- -- The description with some tricks@@ -769,13 +781,13 @@ (\ a b -> b{bis = update (bis b) i (\bi -> bi{ldOptions = a})}) optsEditor , mkField- (paraName <<<- ParaName "A list of header files already installed on the system"+ (paraName <<<- ParaName "A list of header files to use when compiling" $ paraDirection <<<- ParaDirection Vertical $ emptyParams) (includes . (\a -> a !! i) . bis) (\ a b -> b{bis = update (bis b) i (\bi -> bi{includes = a})}) (stringsEditor (const True)) , mkField- (paraName <<<- ParaName "A list of header files from this package"+ (paraName <<<- ParaName "A list of header files to install" $ paraDirection <<<- ParaDirection Vertical $ emptyParams) (installIncludes . (\a -> a !! i) . bis) (\ a b -> b{bis = update (bis b) i (\bi -> bi{installIncludes = a})})
src/IDE/Pane/PackageFlags.hs view
@@ -73,11 +73,11 @@ mbPack <- readIDE activePack case mbPack of Just pack -> do- nb <- getNotebook pp+ pp <- getBestPathForId "*Flags"+ nb <- getNotebook pp initFlags pack pp nb Nothing -> return () - concatString :: [String] -> String concatString l = foldl' (\r s -> if null r then s else r ++ " " ++ s) "" l @@ -197,9 +197,7 @@ ideMessage Normal "can't edit flags without active package" return Nothing Just pack -> do- prefs <- readIDE prefs- layout <- readIDE layout- let pp = getStandardPanePath (sourcePanePath prefs) layout+ pp <- getBestPathForId "*Flags" nb <- getNotebook pp initFlags pack pp nb mbFlags <- getPane@@ -216,40 +214,44 @@ initFlags idePackage panePath nb = do let flagsDesc = extractFieldDescription flagsDescription let flatflagsDesc = flattenFieldDescription flagsDesc- (buf,cids) <- reifyIDE $ \ ideR -> do- vb <- vBoxNew False 0- let flagsPane = IDEFlags vb- bb <- hButtonBoxNew- ok <- buttonNewFromStock "gtk-ok"- closeB <- buttonNewFromStock "gtk-close"- boxPackStart bb ok PackNatural 0- boxPackStart bb closeB PackNatural 0- (widget,injb,ext,notifier)- <- buildEditor flagsDesc idePackage- sw <- scrolledWindowNew Nothing Nothing- scrolledWindowAddWithViewport sw widget- scrolledWindowSetPolicy sw PolicyAutomatic PolicyAutomatic- ok `onClicked` (do- mbPackWithNewFlags <- extract idePackage [ext]- case mbPackWithNewFlags of- Nothing -> return ()- Just packWithNewFlags -> do- reflectIDE (do- modifyIDE_ (\ide -> return (ide{activePack = Just packWithNewFlags}))- close flagsPane) ideR -- we don't trigger the activePack event here- writeFlags ((dropFileName (cabalFile packWithNewFlags)) </> "IDE.flags")- packWithNewFlags)- closeB `onClicked` (reflectIDE (close flagsPane) ideR)- registerEvent notifier FocusIn (Left (\e -> do- reflectIDE (makeActive flagsPane) ideR- return (e{gtkReturn=False})))- boxPackStart vb sw PackGrow 7- boxPackEnd vb bb PackNatural 7- notebookInsertOrdered nb vb (paneName flagsPane) Nothing- widgetShowAll vb- return (flagsPane,[])- addPaneAdmin buf [] panePath- liftIO $ widgetGrabFocus (flagsBox buf)--+ newPane panePath nb (builder idePackage flagsDesc flatflagsDesc)+ return () +builder :: IDEPackage ->+ FieldDescription IDEPackage ->+ [FieldDescription IDEPackage] ->+ PanePath ->+ Notebook ->+ Window ->+ IDERef ->+ IO (IDEFlags,Connections)+builder idePackage flagsDesc flatflagsDesc pp nb window ideR = do+ vb <- vBoxNew False 0+ let flagsPane = IDEFlags vb+ bb <- hButtonBoxNew+ ok <- buttonNewFromStock "gtk-ok"+ closeB <- buttonNewFromStock "gtk-close"+ boxPackStart bb ok PackNatural 0+ boxPackStart bb closeB PackNatural 0+ (widget,injb,ext,notifier)+ <- buildEditor flagsDesc idePackage+ sw <- scrolledWindowNew Nothing Nothing+ scrolledWindowAddWithViewport sw widget+ scrolledWindowSetPolicy sw PolicyAutomatic PolicyAutomatic+ ok `onClicked` (do+ mbPackWithNewFlags <- extract idePackage [ext]+ case mbPackWithNewFlags of+ Nothing -> return ()+ Just packWithNewFlags -> do+ reflectIDE (do+ modifyIDE_ (\ide -> ide{activePack = Just packWithNewFlags})+ close flagsPane) ideR -- we don't trigger the activePack event here+ writeFlags ((dropFileName (cabalFile packWithNewFlags)) </> "IDE.flags")+ packWithNewFlags)+ closeB `onClicked` (reflectIDE (close flagsPane >> return ()) ideR)+ registerEvent notifier FocusIn (Left (\e -> do+ reflectIDE (makeActive flagsPane) ideR+ return (e{gtkReturn=False})))+ boxPackStart vb sw PackGrow 7+ boxPackEnd vb bb PackNatural 7+ return (flagsPane,[])
src/IDE/Pane/Preferences.hs view
@@ -53,6 +53,12 @@ import System.IO import Distribution.InstalledPackageInfo (package) import IDE.Metainfo.GHCUtils (getInstalledPackageInfos,inGhc)+import Packages (PackageConfig(..))+import IDE.Debug+ (debugSetPrintBindResult,+ debugSetBreakOnError,+ debugSetBreakOnException,+ debugSetPrintEvldWithShow) -- -- | The Preferences Pane@@ -94,9 +100,7 @@ mbPrefs <- getPane case mbPrefs of Nothing -> do- prefs <- readIDE prefs- layout <- readIDE layout- let pp = getStandardPanePath (sourcePanePath prefs) layout+ pp <- getBestPathForId "*Prefs" nb <- getNotebook pp initPrefs pp nb mbPrefs <- getPane@@ -115,56 +119,62 @@ let flatPrefsDesc = flattenFieldDescriptionPP (prefsDescription (map package packageInfos)) prefs <- readIDE prefs lastAppliedPrefsRef <- liftIO $ newIORef prefs- panes <- readIDE panes- paneMap <- readIDE paneMap currentInfo <- readIDE currentInfo- (buf,cids) <- reifyIDE $ \ideR -> do- vb <- vBoxNew False 0- bb <- hButtonBoxNew- apply <- buttonNewFromStock "gtk-apply"- restore <- buttonNewFromStock "Restore"- save <- buttonNewFromStock "gtk-save"- closeB <- buttonNewFromStock "gtk-close"- boxPackStart bb apply PackNatural 0- boxPackStart bb restore PackNatural 0- boxPackStart bb save PackNatural 0- boxPackStart bb closeB PackNatural 0- (widget,injb,ext,notifier) <- buildEditor (extractFieldDescription $ prefsDescription (map package packageInfos)) prefs- boxPackStart vb widget PackGrow 7- boxPackEnd vb bb PackNatural 7- let prefsPane = IDEPrefs vb- apply `onClicked` (do- mbNewPrefs <- extract prefs [ext]- case mbNewPrefs of- Nothing -> return ()- Just newPrefs -> do- lastAppliedPrefs <- readIORef lastAppliedPrefsRef- mapM_ (\ (FDPP _ _ _ _ applyF) -> reflectIDE (applyF newPrefs lastAppliedPrefs) ideR ) flatPrefsDesc- writeIORef lastAppliedPrefsRef newPrefs)- restore `onClicked` (do- lastAppliedPrefs <- readIORef lastAppliedPrefsRef- mapM_ (\ (FDPP _ _ _ _ applyF) -> reflectIDE (applyF prefs lastAppliedPrefs) ideR ) flatPrefsDesc- injb prefs- writeIORef lastAppliedPrefsRef prefs)- save `onClicked` (do- lastAppliedPrefs <- readIORef lastAppliedPrefsRef- mbNewPrefs <- extract prefs [ext]- case mbNewPrefs of- Nothing -> return ()- Just newPrefs -> do+ newPane panePath nb2 (builder lastAppliedPrefsRef packageInfos flatPrefsDesc prefs)+ return ()++builder :: IORef Prefs ->+ [PackageConfig] ->+ [FieldDescriptionPP Prefs] ->+ Prefs ->+ PanePath ->+ Notebook ->+ Window ->+ IDERef ->+ IO (IDEPrefs,Connections)+builder lastAppliedPrefsRef packageInfos flatPrefsDesc prefs pp nb windows ideR = do+ vb <- vBoxNew False 0+ bb <- hButtonBoxNew+ apply <- buttonNewFromStock "gtk-apply"+ restore <- buttonNewFromStock "Restore"+ save <- buttonNewFromStock "gtk-save"+ closeB <- buttonNewFromStock "gtk-close"+ boxPackStart bb apply PackNatural 0+ boxPackStart bb restore PackNatural 0+ boxPackStart bb save PackNatural 0+ boxPackStart bb closeB PackNatural 0+ (widget,injb,ext,notifier) <- buildEditor (extractFieldDescription $ prefsDescription (map package packageInfos)) prefs+ boxPackStart vb widget PackGrow 7+ boxPackEnd vb bb PackNatural 7+ let prefsPane = IDEPrefs vb+ apply `onClicked` (do+ mbNewPrefs <- extract prefs [ext]+ case mbNewPrefs of+ Nothing -> return ()+ Just newPrefs -> do+ lastAppliedPrefs <- readIORef lastAppliedPrefsRef mapM_ (\ (FDPP _ _ _ _ applyF) -> reflectIDE (applyF newPrefs lastAppliedPrefs) ideR ) flatPrefsDesc- fp <- getConfigFilePathForSave "Default.prefs"- writePrefs fp newPrefs- reflectIDE (modifyIDE_ (\ide -> return (ide{prefs = newPrefs}))) ideR )- closeB `onClicked` (reflectIDE (close prefsPane) ideR )- registerEvent notifier FocusIn (Left (\e -> do- reflectIDE (makeActive prefsPane) ideR- return (e{gtkReturn=False})))- notebookInsertOrdered nb2 vb (paneName prefsPane) Nothing- widgetShowAll vb- return (prefsPane,[])- addPaneAdmin buf [] panePath- liftIO $widgetGrabFocus (prefsBox buf)+ writeIORef lastAppliedPrefsRef newPrefs)+ restore `onClicked` (do+ lastAppliedPrefs <- readIORef lastAppliedPrefsRef+ mapM_ (\ (FDPP _ _ _ _ applyF) -> reflectIDE (applyF prefs lastAppliedPrefs) ideR ) flatPrefsDesc+ injb prefs+ writeIORef lastAppliedPrefsRef prefs)+ save `onClicked` (do+ lastAppliedPrefs <- readIORef lastAppliedPrefsRef+ mbNewPrefs <- extract prefs [ext]+ case mbNewPrefs of+ Nothing -> return ()+ Just newPrefs -> do+ mapM_ (\ (FDPP _ _ _ _ applyF) -> reflectIDE (applyF newPrefs lastAppliedPrefs) ideR ) flatPrefsDesc+ fp <- getConfigFilePathForSave "Default.prefs"+ writePrefs fp newPrefs+ reflectIDE (modifyIDE_ (\ide -> ide{prefs = newPrefs})) ideR )+ closeB `onClicked` (reflectIDE (close prefsPane >> return ()) ideR )+ registerEvent notifier FocusIn (Left (\e -> do+ reflectIDE (makeActive prefsPane) ideR+ return (e{gtkReturn=False})))+ return (prefsPane,[]) -- ------------------------------------------------------------@@ -331,40 +341,62 @@ boolEditor (\i -> return ()) , mkFieldPP- (paraName <<<- ParaName "Standard source pane path" $ emptyParams)+ (paraName <<<- ParaName "Name of the keymap"+ $ paraSynopsis <<<- ParaSynopsis+ "The name of a keymap file in a config dir"+ $ paraDirection <<<- ParaDirection Horizontal $ emptyParams)+ PP.text+ identifier+ keymapName+ (\b a -> a{keymapName = b})+ (stringEditor (\s -> not (null s)))+ (\ a -> return ())+ ]),+ ("Initial Pane positions", VFDPP emptyParams [+ mkFieldPP+ (paraName <<<- ParaName+ "Categories for panes"+ $ paraShadow <<<- ParaShadow ShadowIn+ $ paraDirection <<<- ParaDirection Vertical $ emptyParams) (PP.text . show) readParser- sourcePanePath- (\b a -> a{sourcePanePath = b})- panePathEditor+ categoryForPane+ (\b a -> a{categoryForPane = b})+ (multisetEditor+ (ColumnDescr True [("Pane Id",\(n,_) -> [cellText := n])+ ,("Pane Category",\(_,v) -> [cellText := v])])+ ((pairEditor+ (stringEditor (\s -> not (null s)),emptyParams)+ (stringEditor (\s -> not (null s)),emptyParams)),emptyParams)+ Nothing+ Nothing) (\i -> return ()) , mkFieldPP- (paraName <<<- ParaName "Standard log pane path" $ emptyParams)+ (paraName <<<- ParaName+ "Pane path for category"+ $ paraShadow <<<- ParaShadow ShadowIn+ $ paraDirection <<<- ParaDirection Vertical $ emptyParams) (PP.text . show) readParser- logPanePath- (\b a -> a{logPanePath = b})- panePathEditor+ pathForCategory+ (\b a -> a{pathForCategory = b})+ (multisetEditor+ (ColumnDescr True [("Pane category",\(n,_) -> [cellText := n])+ ,("Pane path",\(_,v) -> [cellText := show v])])+ ((pairEditor+ (stringEditor (\s -> not (null s)),emptyParams)+ (genericEditor,emptyParams)),emptyParams)+ Nothing+ Nothing) (\i -> return ()) , mkFieldPP- (paraName <<<- ParaName "Standard modules pane path" $ emptyParams)+ (paraName <<<- ParaName "Default pane path" $ emptyParams) (PP.text . show) readParser- modulesPanePath- (\b a -> a{modulesPanePath = b})- panePathEditor+ defaultPath+ (\b a -> a{defaultPath = b})+ genericEditor (\i -> return ())- , mkFieldPP- (paraName <<<- ParaName "Name of the keymap"- $ paraSynopsis <<<- ParaSynopsis- "The name of a keymap file in a config dir"- $ paraDirection <<<- ParaDirection Horizontal $ emptyParams)- PP.text- identifier- keymapName- (\b a -> a{keymapName = b})- (stringEditor (\s -> not (null s)))- (\ a -> return ()) ]), ("Metadata", VFDPP emptyParams [ mkFieldPP@@ -439,6 +471,40 @@ boolEditor (\i -> return ()) ]),+ ("Debug", VFDPP emptyParams [+ mkFieldPP+ (paraName <<<- ParaName "Enable usage of Show instances in :print" $ emptyParams)+ (PP.text . show)+ boolParser+ printEvldWithShow+ (\b a -> a{printEvldWithShow = b})+ boolEditor+ debugSetPrintEvldWithShow+ , mkFieldPP+ (paraName <<<- ParaName "Break on any exception thrown" $ emptyParams)+ (PP.text . show)+ boolParser+ breakOnException+ (\b a -> a{breakOnException = b})+ boolEditor+ debugSetBreakOnException+ , mkFieldPP+ (paraName <<<- ParaName "Break on uncaught exceptions and errors" $ emptyParams)+ (PP.text . show)+ boolParser+ breakOnError+ (\b a -> a{breakOnError = b})+ boolEditor+ debugSetBreakOnError+ , mkFieldPP+ (paraName <<<- ParaName "Turn on printing of binding results in GHCi" $ emptyParams)+ (PP.text . show)+ boolParser+ printBindResult+ (\b a -> a{printBindResult = b})+ boolEditor+ debugSetPrintBindResult+ ]), ("Help", VFDPP emptyParams [ mkFieldPP (paraName <<<- ParaName "Browser" $ emptyParams)@@ -469,11 +535,7 @@ ids <- sourceStyleSchemeManagerGetSchemeIds styleManager maybeEditor (comboSelectionEditor ids id, p) True "Select a special style?" p n -panePathEditor :: Editor StandardPath-panePathEditor = genericEditor -- instance Default PackageIdentifier where getDefault = case toPackageIdentifier "unknown-0" of Nothing -> throwIDE "Preferences.getDefault: Can't parse Package Identifier"@@ -492,11 +554,24 @@ , logviewFont = Nothing , defaultSize = (1024,800) , browser = "firefox"- , sourcePanePath = [LeftP]- , logPanePath = [RightP,BottomP]- , modulesPanePath = [RightP,TopP] , sourceDirectories = [] , packageBlacklist = []+ , pathForCategory = [ ("EditorCategory",[SplitP (LeftP)])+ , ("TreeCategory",[SplitP (RightP),SplitP (TopP)])+ , ("LogCategory",[SplitP (RightP), SplitP (BottomP)])+ , ("DialogCategory",[SplitP (RightP),SplitP (TopP)])]+ , defaultPath = [SplitP (LeftP)]+ , categoryForPane = [ ("*ClassHierarchy","TreeCategory")+ , ("*Debug","TreeCategory")+ , ("*Grep","TreeCategory")+ , ("*Info","LogCategory")+ , ("*Log","LogCategory")+ , ("*Modules","TreeCategory")+ , ("*Package","DialogCategory")+ , ("*Flags","DialogCategory")+ , ("*Prefs","DialogCategory")+ , ("*References","LogCategory")+ , ("*Search","TreeCategory")] , collectAfterBuild = False , collectAtStart = True , autoExtractTars = Nothing@@ -511,6 +586,10 @@ #else True #endif+ , printEvldWithShow = True+ , breakOnException = True+ , breakOnError = True+ , printBindResult = False } -- ------------------------------------------------------------
src/IDE/Pane/References.hs view
@@ -135,9 +135,7 @@ mbMod <- getPane case mbMod of Nothing -> do- prefs <- readIDE prefs- layout <- readIDE layout- let pp = getStandardPanePath (logPanePath prefs) layout+ pp <- getBestPathForId "*References" nb <- getNotebook pp initReferences pp nb Nothing mbMod <- getPane@@ -163,87 +161,88 @@ 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+ newPane panePath nb (builder scope)+ return () - listStore <- listStoreNew []- treeView <- treeViewNew- treeViewSetModel treeView listStore+builder :: Scope ->+ PanePath ->+ Notebook ->+ Window ->+ IDERef ->+ IO (IDEReferences,Connections)+builder scope pp nb windows 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 - renderer0 <- cellRendererPixbufNew- set renderer0 [ cellPixbufStockId := stockYes ]+ listStore <- listStoreNew []+ treeView <- treeViewNew+ treeViewSetModel treeView listStore - 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]+ renderer0 <- cellRendererPixbufNew+ set renderer0 [ cellPixbufStockId := 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]+ 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] - treeViewSetHeadersVisible treeView True- sel <- treeViewGetSelection treeView- treeSelectionSetMode sel SelectionSingle+ 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] - 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 )+ treeViewSetHeadersVisible treeView True+ sel <- treeViewGetSelection treeView+ treeSelectionSetMode sel SelectionSingle - return (references,[ConnectC cid1])- addPaneAdmin buf cids panePath- liftIO $widgetGrabFocus (scrolledView buf)+ 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+ scopeRef <- newIORef scope+ let references = IDEReferences sw treeView referencesDescr' listStore scopeRef entry box+ 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]) getSelectionTree :: TreeView@@ -314,7 +313,7 @@ focusFindEntry reifyIDE $ \ideR -> do idleAdd (do- reflectIDE (editFind True True True text "" Forward) ideR+ reflectIDE (editFind True True True False text "" Forward) ideR return False) priorityDefaultIdle return True
src/IDE/Pane/Search.hs view
@@ -74,7 +74,7 @@ return (Just (SearchState str scope mode)) recoverState pp (SearchState str scope mode) = do nb <- getNotebook pp- initSearch pp nb scope mode+ newPane pp nb (builder scope mode) searchMetaGUI str showSearch :: IDEAction@@ -89,158 +89,152 @@ case mbSearch of Just m -> return m Nothing -> do- prefs <- readIDE prefs- layout <- readIDE layout- let pp = getStandardPanePath (modulesPanePath prefs) layout- nb <- getNotebook pp- initSearch pp nb System (Prefix False)+ pp <- getBestPathForId "*Search"+ nb <- getNotebook pp+ newPane pp nb (builder System (Prefix False)) mbSearch <- getPane case mbSearch of Nothing -> throwIDE "Can't init search" Just m -> return m -initSearch :: PanePath -> Notebook -> Scope -> SearchMode -> IDEAction-initSearch panePath nb scope mode = do- panes <- readIDE panes- paneMap <- readIDE paneMap- 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+builder :: Scope ->+ SearchMode ->+ PanePath ->+ Notebook ->+ Window ->+ IDERef ->+ IO (IDESearch,Connections)+builder scope mode pp nb windows 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 - modebox <- hBoxNew True 2- mb1 <- radioButtonNewWithLabel "Exact"- mb2 <- radioButtonNewWithLabelFromWidget mb1 "Prefix"- mb3 <- radioButtonNewWithLabelFromWidget mb1 "Regex"- toggleButtonSetActive- (case mode of- Exact _ -> mb1- Prefix _ -> mb2- Regex _ -> mb3) True- mb4 <- checkButtonNewWithLabel "Case sensitive"- toggleButtonSetActive mb4 (caseSense mode)- boxPackStart modebox mb1 PackNatural 2- boxPackStart modebox mb2 PackNatural 2- boxPackStart modebox mb3 PackNatural 2- boxPackEnd modebox mb4 PackNatural 2+ modebox <- hBoxNew True 2+ mb1 <- radioButtonNewWithLabel "Exact"+ mb2 <- radioButtonNewWithLabelFromWidget mb1 "Prefix"+ mb3 <- radioButtonNewWithLabelFromWidget mb1 "Regex"+ toggleButtonSetActive+ (case mode of+ Exact _ -> mb1+ Prefix _ -> mb2+ Regex _ -> mb3) True+ mb4 <- checkButtonNewWithLabel "Case sensitive"+ toggleButtonSetActive mb4 (caseSense mode)+ boxPackStart modebox mb1 PackNatural 2+ boxPackStart modebox mb2 PackNatural 2+ boxPackStart modebox mb3 PackNatural 2+ boxPackEnd modebox mb4 PackNatural 2 - listStore <- listStoreNew []- treeView <- treeViewNew- treeViewSetModel treeView listStore+ listStore <- listStoreNew []+ treeView <- treeViewNew+ treeViewSetModel treeView 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 -> [- cellPixbufStockId := stockIdFromType ((descrType . details) row)]+ 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 -> [+ cellPixbufStockId := stockIdFromType ((descrType . details) row)] - 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 -> [- cellPixbufStockId := if isReexported row- then "ide_reexported"- else if isJust (mbLocation row)- then "ide_source"- else ""]+ 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 -> [+ cellPixbufStockId := if isReexported row+ then "ide_reexported"+ else if isJust (mbLocation row)+ then "ide_source"+ else ""] - 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]+ 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] - treeViewSetHeadersVisible treeView True- sel <- treeViewGetSelection treeView- treeSelectionSetMode sel SelectionSingle+ treeViewSetHeadersVisible treeView True+ sel <- treeViewGetSelection treeView+ treeSelectionSetMode sel SelectionSingle - sw <- scrolledWindowNew Nothing Nothing- containerAdd sw treeView- scrolledWindowSetPolicy sw PolicyAutomatic PolicyAutomatic+ sw <- scrolledWindowNew Nothing Nothing+ containerAdd sw treeView+ scrolledWindowSetPolicy sw PolicyAutomatic PolicyAutomatic - entry <- entryNew+ entry <- entryNew - box <- vBoxNew False 2- boxPackStart box scopebox PackNatural 0- boxPackStart box sw PackGrow 0- boxPackStart box modebox PackNatural 0- boxPackEnd box entry PackNatural 0+ box <- vBoxNew False 2+ boxPackStart box scopebox PackNatural 0+ boxPackStart box sw PackGrow 0+ boxPackStart box modebox PackNatural 0+ boxPackEnd box entry PackNatural 0 - scopeRef <- newIORef scope- modeRef <- newIORef mode- let search = IDESearch sw treeView listStore scopeRef modeRef box entry- notebookInsertOrdered nb box (paneName search) Nothing+ scopeRef <- newIORef scope+ modeRef <- newIORef mode+ let search = IDESearch sw treeView listStore scopeRef modeRef box entry - cid1 <- treeView `afterFocusIn`- (\_ -> do reflectIDE (makeActive search) ideR ; return True)- rb1 `onToggled` (reflectIDE (scopeSelection Local) ideR )- rb2 `onToggled` (reflectIDE (scopeSelection Package) ideR )- rb3 `onToggled` (reflectIDE (scopeSelection System) ideR )- mb1 `onToggled` do- widgetSetSensitivity mb4 False- active <- toggleButtonGetActive mb4- (reflectIDE (modeSelection (Exact active)) ideR )- mb2 `onToggled`do- widgetSetSensitivity mb4 True- active <- toggleButtonGetActive mb4- (reflectIDE (modeSelection (Prefix active)) ideR )- mb3 `onToggled` do- widgetSetSensitivity mb4 True- active <- toggleButtonGetActive mb4- (reflectIDE (modeSelection (Regex active)) ideR )- mb4 `onToggled` do- active <- toggleButtonGetActive mb4- (reflectIDE (modeSelectionCase active) ideR )- treeView `onButtonPress` (listViewPopup ideR listStore treeView)- sel `onSelectionChanged` do- fillInfo search ideR- entry `afterKeyRelease` (\ event -> do- text <- entryGetText entry- reflectIDE (searchMetaGUI text) ideR- return False)- return (search,[ConnectC cid1])- addPaneAdmin buf cids panePath- liftIO $ widgetShowAll (topBox buf)- liftIO $ widgetGrabFocus (scrolledView buf)+ cid1 <- treeView `afterFocusIn`+ (\_ -> do reflectIDE (makeActive search) ideR ; return True)+ rb1 `onToggled` (reflectIDE (scopeSelection Local) ideR )+ rb2 `onToggled` (reflectIDE (scopeSelection Package) ideR )+ rb3 `onToggled` (reflectIDE (scopeSelection System) ideR )+ mb1 `onToggled` do+ widgetSetSensitivity mb4 False+ active <- toggleButtonGetActive mb4+ (reflectIDE (modeSelection (Exact active)) ideR )+ mb2 `onToggled`do+ widgetSetSensitivity mb4 True+ active <- toggleButtonGetActive mb4+ (reflectIDE (modeSelection (Prefix active)) ideR )+ mb3 `onToggled` do+ widgetSetSensitivity mb4 True+ active <- toggleButtonGetActive mb4+ (reflectIDE (modeSelection (Regex active)) ideR )+ mb4 `onToggled` do+ active <- toggleButtonGetActive mb4+ (reflectIDE (modeSelectionCase active) ideR )+ treeView `onButtonPress` (listViewPopup ideR listStore treeView)+ sel `onSelectionChanged` do+ fillInfo search ideR+ entry `afterKeyRelease` (\ event -> do+ text <- entryGetText entry+ reflectIDE (searchMetaGUI text) ideR+ return False)+ return (search,[ConnectC cid1]) getScope :: IDESearch -> IO Scope getScope search = readIORef (searchScopeRef search)@@ -339,7 +333,7 @@ Just descr -> do reflectIDE (setInfo descr) ideR entrySetText (entry search) (descrName descr)- otherwise -> sysMessage Normal "Search>>fillInfo:no selection"+ otherwise -> return () setChoices :: [Descr] -> IDEAction setChoices descrs = do
src/IDE/Pane/SourceBuffer.hs view
@@ -21,13 +21,10 @@ , allBuffers , maybeActiveBuf-, standardSourcePanePath , selectSourceBuf , goToSourceDefinition , goToDefinition -, newTextBuffer- , fileNew , fileOpenThis , fileOpen@@ -57,7 +54,7 @@ , editKeystrokeCandy , editCandy -, markErrorInSourceBuf+, markRefInSourceBuf , inBufContext' , inBufContext , inActiveBufContext'@@ -65,6 +62,13 @@ , align , startComplete++, selectedText+, insertTextAfterSelection+, selectedModuleName+, selectedLocation+, recentSourceBuffers+, newTextBuffer ) where import Graphics.UI.Gtk hiding (afterToggleOverwrite)@@ -73,7 +77,6 @@ import Graphics.UI.Gtk.General.Enums (Click(..)) import Graphics.UI.Gtk.Gdk.Events (eventClick) import Control.Monad.Reader---import Data.IORef import System.IO import System.FilePath import System.Directory@@ -95,6 +98,10 @@ import Graphics.UI.Frame.Panes (IDEPane(..)) import Data.Char (isAlphaNum) import Control.Event (triggerEvent)+import SrcLoc+ (srcLocCol, srcLocLine, srcSpanEnd, srcSpanStart)+import IDE.Metainfo.GHCUtils (parseHeader)+import GHC (SrcLoc(..), unLoc, moduleNameString, HsModule(..)) -- -- | A text editor pane description@@ -110,6 +117,7 @@ } deriving (Typeable) data BufferState = BufferState FilePath Int+ | BufferStateTrans String String Int deriving(Eq,Ord,Read,Show,Typeable) instance IDEObject IDEBuffer@@ -145,16 +153,11 @@ id6 <- sv `afterToggleOverwrite` writeOverwriteInStatusbar sv sbIO return [ConnectC id2,ConnectC id6,ConnectC id1,ConnectC id3] activatePane actbuf cids- liftIO $- idleAdd (do- widgetQueueDraw sv -- Patch for problem on one machine ##- return False) priorityDefaultIdle- triggerEvent ideR (Sensitivity [(SensitivityEditor, True)])+ triggerEventIDE (Sensitivity [(SensitivityEditor, True)]) checkModTime actbuf return () close pane = do makeActive pane fileClose- return () instance RecoverablePane IDEBuffer BufferState IDEM where saveState p = do buf <- liftIO $ textViewGetBuffer (sourceView p)@@ -162,13 +165,15 @@ iter <- liftIO $ textBufferGetIterAtMark buf ins offset <- liftIO $ textIterGetOffset iter case fileName p of- Nothing -> return Nothing+ Nothing -> do+ ct <- readIDE candy+ text <- liftIO $ getCandylessText ct buf+ return (Just (BufferStateTrans (bufferName p) text offset)) Just fn -> return (Just (BufferState fn offset)) recoverState pp (BufferState n i) = do- exists <- liftIO $doesFileExist n- when exists $ do- buf <- newTextBuffer pp (takeFileName n) (Just n)- liftIO $ do+ mbbuf <- newTextBuffer pp (takeFileName n) (Just n)+ case mbbuf of+ Just buf -> liftIO $ do gtkBuf <- textViewGetBuffer (sourceView buf) iter <- textBufferGetIterAtOffset gtkBuf i textBufferPlaceCursor gtkBuf iter@@ -177,7 +182,28 @@ textViewScrollToMark (sourceView buf) mark 0.0 (Just (0.3,0.3)) return False) priorityDefaultIdle return ()+ Nothing -> return ()+ recoverState pp (BufferStateTrans bn text i) = do+ mbbuf <- newTextBuffer pp bn Nothing+ useCandy <- getCandyState+ case mbbuf of+ Just buf -> do+ candy' <- readIDE candy+ liftIO $ do+ gtkBuf <- textViewGetBuffer (sourceView buf)+ textBufferSetText gtkBuf text + when useCandy $ transformToCandy candy' gtkBuf+ iter <- textBufferGetIterAtOffset gtkBuf i+ textBufferPlaceCursor gtkBuf iter+ mark <- textBufferGetInsert gtkBuf+ idleAdd (do+ textViewScrollToMark (sourceView buf) mark 0.0 (Just (0.3,0.3))+ return False) priorityDefaultIdle+ return ()+ Nothing -> return ()++ startComplete :: IDEAction startComplete = do trace "start complete" return ()@@ -202,17 +228,23 @@ fe <- liftIO $ doesFileExist fpc if fe then do- path <- standardSourcePanePath- nbuf <- newTextBuffer path (takeFileName fpc) (Just fpc)- return (Just nbuf)+ prefs <- readIDE prefs+ pp <- getBestPathForId "*Buffer"+ nbuf <- newTextBuffer pp (takeFileName fpc) (Just fpc)+ return nbuf else return Nothing -lastActiveBufferPane :: IDEM (Maybe PaneName)-lastActiveBufferPane = do+recentSourceBuffers :: IDEM [PaneName]+recentSourceBuffers = do recentPanes' <- readIDE recentPanes mbBufs <- mapM mbPaneFromName recentPanes'- case (catMaybes $ map (\ (PaneC p) -> cast p) $ catMaybes mbBufs) :: [IDEBuffer] of- (hd : _) -> return (Just (paneName hd))+ return $ map paneName ((catMaybes $ map (\ (PaneC p) -> cast p) $ catMaybes mbBufs) :: [IDEBuffer])++lastActiveBufferPane :: IDEM (Maybe PaneName)+lastActiveBufferPane = do+ rs <- recentSourceBuffers+ case rs of+ (hd : _) -> return (Just hd) _ -> return Nothing goToDefinition :: Descr -> IDEAction@@ -263,43 +295,81 @@ return False) priorityDefaultIdle return () --markErrorInSourceBuf :: Int -> IDEBuffer -> Int -> Int -> String -> Bool -> IDEAction-markErrorInSourceBuf index buf line column string scrollTo =+markRefInSourceBuf :: Int -> IDEBuffer -> LogRef -> Bool -> IDEAction+markRefInSourceBuf index buf logRef scrollTo = do+ useCandy <- getCandyState+ candy' <- readIDE candy+ contextRefs <- readIDE contextRefs inBufContext () buf $ \_ gtkbuf buf _ -> do+ let tagName = (show $ logRefType logRef) ++ show index tagTable <- textBufferGetTagTable gtkbuf- mbTag <- textTagTableLookup tagTable ("Err" ++ show index)+ mbTag <- textTagTableLookup tagTable tagName case mbTag of- Just tag -> do+ Just existingTag -> do i1 <- textBufferGetStartIter gtkbuf i2 <- textBufferGetEndIter gtkbuf- textBufferRemoveTagByName gtkbuf ("Err" ++ show index) i1 i2+ textBufferRemoveTagByName gtkbuf tagName i1 i2 Nothing -> do- errtag <- textTagNew (Just $ "Err" ++ show index)- set errtag[textTagUnderline := UnderlineError]+ errtag <- textTagNew (Just tagName)+ case logRefType logRef of+ ErrorRef -> do+ set errtag[textTagUnderline := UnderlineError]+ WarningRef -> do+ set errtag[textTagUnderline := UnderlineError]+ BreakpointRef -> do+ set errtag[textTagBackground := "yellow"]+ ContextRef -> do+ set errtag[textTagBackground := "pink"] textTagTableAdd tagTable errtag + let start' = srcLocToPair $ srcSpanStart (logRefSrcSpan logRef)+ let end' = srcLocToPair $ srcSpanEnd (logRefSrcSpan logRef)+ start <- if useCandy+ then positionToCandy candy' gtkbuf start'+ else return start'+ end <- if useCandy+ then positionToCandy candy' gtkbuf end'+ else return end' lines <- textBufferGetLineCount gtkbuf- iter <- textBufferGetIterAtLine gtkbuf (max 0 (min (lines-1) (line-1)))+ iter <- textBufferGetIterAtLine gtkbuf (max 0 (min (lines-1) ((fst start)-1))) chars <- textIterGetCharsInLine iter- textIterSetLineOffset iter (max 0 (min (chars-1) column))- iter2 <- textIterCopy iter- textIterForwardWordEnd iter2- textBufferApplyTagByName gtkbuf ("Err" ++ show index) iter iter2+ textIterSetLineOffset iter (max 0 (min (chars-1) (snd start)))++ iter2 <- if start == end+ then do+ copy <- textIterCopy iter+ textIterForwardWordEnd copy+ return copy+ else do+ new <- textBufferGetIterAtLine gtkbuf (max 0 (min (lines-1) ((fst end)-1)))+ chars <- textIterGetCharsInLine new+ textIterSetLineOffset new (max 0 (min (chars-1) (snd end)))+ textIterForwardChar new+ return new++ let latest = if null contextRefs then Nothing else Just $ last contextRefs+ let isOldContext = case (logRefType logRef, latest) of+ (ContextRef, Just ctx) | ctx /= logRef -> True+ _ -> False+ unless isOldContext $ textBufferApplyTagByName gtkbuf tagName iter iter2 when scrollTo $ textBufferPlaceCursor gtkbuf iter mark <- textBufferGetInsert gtkbuf when scrollTo $ do idleAdd (do textViewScrollToMark (sourceView buf) mark 0.3 Nothing+ when (isOldContext && scrollTo) $ textBufferSelectRange gtkbuf iter iter2 return False) priorityDefaultIdle return () +srcLocToPair :: SrcLoc -> (Int,Int)+srcLocToPair srcLoc = (srcLocLine srcLoc, srcLocCol srcLoc)+ allBuffers :: IDEM [IDEBuffer] allBuffers = getPanes maybeActiveBuf :: IDEM (Maybe IDEBuffer) maybeActiveBuf = do- mbActivePane <- readIDE activePane+ mbActivePane <- getActivePane mbPane <- lastActiveBufferPane case (mbPane,mbActivePane) of (Just paneName1, Just (paneName2,_)) | paneName1 == paneName2 -> do@@ -308,188 +378,197 @@ return mbActbuf _ -> return Nothing -standardSourcePanePath :: IDEM PanePath-standardSourcePanePath = do- layout <- readIDE layout- prefs <- readIDE prefs- return (getStandardPanePath (sourcePanePath prefs) layout)--newTextBuffer :: PanePath -> String -> Maybe FilePath -> IDEM IDEBuffer+newTextBuffer :: PanePath -> String -> Maybe FilePath -> IDEM (Maybe IDEBuffer) newTextBuffer panePath bn mbfn = do- -- create the appropriate language- nb <- getNotebook panePath- panes <- readIDE panes- paneMap <- readIDE paneMap- prefs <- readIDE prefs- bs <- getCandyState- ct <- readIDE candy- let (ind,rbn) = figureOutPaneName panes bn 0- (buf,cids) <- reifyIDE $ \ideR -> do- lm <- sourceLanguageManagerNew- (mbLanguage, mbSLang) <- sourceLanguageForFilename lm mbfn+ cont <- case mbfn of+ Nothing -> return True+ Just fn -> liftIO $ doesFileExist fn+ if cont+ then do+ nb <- getNotebook panePath+ prefs <- readIDE prefs+ bs <- getCandyState+ ct <- readIDE candy+ (ind,rbn) <- figureOutPaneName bn 0+ pane <- newPane panePath nb (builder bs mbfn ind bn rbn ct prefs)+ return (Just pane)+ else do+ ideMessage Normal ("File does not exist " ++ (fromJust mbfn))+ return Nothing - -- create a new SourceBuffer object- buffer <- case mbSLang of- Just sLang -> sourceBufferNewWithLanguage sLang- Nothing -> sourceBufferNew Nothing- sourceBufferSetMaxUndoLevels buffer (-1)- tagTable <- textBufferGetTagTable buffer- foundTag <- textTagNew (Just "found")- set foundTag [textTagBackground := "yellow"]- textTagTableAdd tagTable foundTag+builder :: Bool ->+ Maybe FilePath ->+ Int ->+ String ->+ String ->+ CandyTable ->+ Prefs ->+ PanePath ->+ Notebook ->+ Window ->+ IDERef ->+ IO (IDEBuffer,Connections)+builder bs mbfn ind bn rbn ct prefs pp nb windows ideR = do+ lm <- sourceLanguageManagerNew+ (mbLanguage, mbSLang) <- sourceLanguageForFilename lm mbfn - -- load up and display a file- (fileContents,modTime) <- case mbfn of- Just fn -> do- fc <- UTF8.readFile fn- mt <- getModificationTime fn- return (fc,Just mt)- Nothing -> return ("\n\n\n\n\n",Nothing)- sourceBufferBeginNotUndoableAction buffer- textBufferSetText buffer fileContents- when bs $ transformToCandy ct (castToTextBuffer buffer)- sourceBufferEndNotUndoableAction buffer- textBufferSetModified buffer False- siter <- textBufferGetStartIter buffer- textBufferPlaceCursor buffer siter- iter <- textBufferGetEndIter buffer- textBufferCreateMark buffer (Just "end") iter True+ -- create a new SourceBuffer object+ buffer <- case mbSLang of+ Just sLang -> sourceBufferNewWithLanguage sLang+ Nothing -> sourceBufferNew Nothing+ sourceBufferSetMaxUndoLevels buffer (-1)+ tagTable <- textBufferGetTagTable buffer+ foundTag <- textTagNew (Just "found")+ set foundTag [textTagBackground := "yellow"]+ textTagTableAdd tagTable foundTag - -- create a new SourceView Widget- sv <- sourceViewNewWithBuffer buffer- fd <- case textviewFont prefs of- Just str -> do- fontDescriptionFromString str- Nothing -> do- f <- fontDescriptionNew- fontDescriptionSetFamily f "Monospace"- return f- widgetModifyFont sv (Just fd)- set sv [sourceViewHighlightCurrentLine := True]- sourceViewSetShowLineNumbers sv (showLineNumbers prefs)- case rightMargin prefs of- Just n -> do- set sv [sourceViewShowRightMargin := True]- sourceViewSetRightMarginPosition sv (fromIntegral n)- Nothing -> set sv [sourceViewShowRightMargin := False]- sourceViewSetInsertSpacesInsteadOfTabs sv True- sourceViewSetIndentWidth sv (tabWidth prefs)- sourceViewSetTabWidth sv (tabWidth prefs)- sourceViewSetIndentOnTab sv True- sourceViewSetAutoIndent sv True- sourceViewSetSmartHomeEnd sv SourceSmartHomeEndBefore- case sourceStyle prefs of- Nothing -> return ()- Just str -> do- styleManager <- sourceStyleSchemeManagerNew- ids <- sourceStyleSchemeManagerGetSchemeIds styleManager- when (elem str ids) $ do- scheme <- sourceStyleSchemeManagerGetScheme styleManager str- sourceBufferSetStyleScheme buffer scheme+ -- load up and display a file+ (fileContents,modTime) <- case mbfn of+ Just fn -> do+ fc <- UTF8.readFile fn+ mt <- getModificationTime fn+ return (fc,Just mt)+ Nothing -> return ("\n",Nothing)+ sourceBufferBeginNotUndoableAction buffer+ textBufferSetText buffer fileContents+ when bs $ transformToCandy ct (castToTextBuffer buffer)+ sourceBufferEndNotUndoableAction buffer+ textBufferSetModified buffer False+ siter <- textBufferGetStartIter buffer+ textBufferPlaceCursor buffer siter+ iter <- textBufferGetEndIter buffer+ textBufferCreateMark buffer (Just "end") iter True - -- put it in a scrolled window- sw <- scrolledWindowNew Nothing Nothing- containerAdd sw sv- scrolledWindowSetPolicy sw PolicyAutomatic PolicyAutomatic- scrolledWindowSetShadowType sw ShadowIn- modTimeRef <- newIORef modTime- let buf = IDEBuffer mbfn bn ind sv sw modTimeRef mbLanguage- notebookInsertOrdered nb sw rbn Nothing- -- events- cid <- sv `afterFocusIn`- (\_ -> do reflectIDE (makeActive buf) ideR ; return False)- buffer `afterBufferInsertText`- (\iter text -> do- case text of- [c] | ((isAlphaNum c) || (c == '.') || (c == '_')) -> do- reflectIDE (Completion.complete sv False) ideR- _ -> return ()- )- sv `onMoveCursor`- (\step n select -> do reflectIDE Completion.cancel ideR)- sv `onButtonPress`- \event -> do- let click = eventClick event- liftIO $ do- reflectIDE Completion.cancel ideR- case click of- DoubleClick -> do- let isSelectChar a = (isAlphaNum a) || (a == '_')- (start, end) <- textBufferGetSelectionBounds buffer- mbStartChar <- textIterGetChar start- mbEndChar <- textIterGetChar end- case mbStartChar of- Just startChar | isSelectChar startChar -> do- found <- textIterBackwardFindChar start (not.isSelectChar) Nothing- when found $ do- textIterForwardChar start- return ()- _ -> return ()- case mbEndChar of- Just endChar | isSelectChar endChar -> do- textIterForwardFindChar end (not.isSelectChar) Nothing+ -- create a new SourceView Widget+ sv <- sourceViewNewWithBuffer buffer+ fd <- case textviewFont prefs of+ Just str -> do+ fontDescriptionFromString str+ Nothing -> do+ f <- fontDescriptionNew+ fontDescriptionSetFamily f "Monospace"+ return f+ widgetModifyFont sv (Just fd)+ set sv [sourceViewHighlightCurrentLine := True]+ sourceViewSetShowLineNumbers sv (showLineNumbers prefs)+ case rightMargin prefs of+ Just n -> do+ set sv [sourceViewShowRightMargin := True]+ sourceViewSetRightMarginPosition sv (fromIntegral n)+ Nothing -> set sv [sourceViewShowRightMargin := False]+ sourceViewSetInsertSpacesInsteadOfTabs sv True+ sourceViewSetIndentWidth sv (tabWidth prefs)+ sourceViewSetTabWidth sv (tabWidth prefs)+ sourceViewSetIndentOnTab sv True+ sourceViewSetAutoIndent sv True+ sourceViewSetSmartHomeEnd sv SourceSmartHomeEndBefore+ case sourceStyle prefs of+ Nothing -> return ()+ Just str -> do+ styleManager <- sourceStyleSchemeManagerNew+ ids <- sourceStyleSchemeManagerGetSchemeIds styleManager+ when (elem str ids) $ do+ scheme <- sourceStyleSchemeManagerGetScheme styleManager str+ sourceBufferSetStyleScheme buffer scheme++ -- put it in a scrolled window+ sw <- scrolledWindowNew Nothing Nothing+ containerAdd sw sv+ scrolledWindowSetPolicy sw PolicyAutomatic PolicyAutomatic+ scrolledWindowSetShadowType sw ShadowIn+ modTimeRef <- newIORef modTime+ let buf = IDEBuffer mbfn bn ind sv sw modTimeRef mbLanguage+ -- events+ cid <- sv `afterFocusIn`+ (\_ -> do reflectIDE (makeActive buf) ideR ; return False)+ buffer `afterBufferInsertText`+ (\iter text -> do+ case text of+ [c] | ((isAlphaNum c) || (c == '.') || (c == '_')) -> do+ reflectIDE (Completion.complete sv False) ideR+ _ -> return ()+ )+ sv `onMoveCursor`+ (\step n select -> do reflectIDE Completion.cancel ideR)+ sv `onButtonPress`+ \event -> do+ let click = eventClick event+ liftIO $ do+ reflectIDE Completion.cancel ideR+ case click of+ DoubleClick -> do+ let isSelectChar a = (isAlphaNum a) || (a == '_')+ (start, end) <- textBufferGetSelectionBounds buffer+ mbStartChar <- textIterGetChar start+ mbEndChar <- textIterGetChar end+ case mbStartChar of+ Just startChar | isSelectChar startChar -> do+ found <- textIterBackwardFindChar start (not.isSelectChar) Nothing+ when found $ do+ textIterForwardChar start return ()- _ -> return ()- textBufferSelectRange buffer start end- return True- _ -> return False- return (buf,[cid])- addPaneAdmin buf (map ConnectC cids) panePath- liftIO $do- widgetShowAll (scrolledWindow buf)- widgetGrabFocus (sourceView buf)- when (isJust mbfn) $ removeRecentlyUsedFile (fromJust mbfn)- return buf+ _ -> return ()+ case mbEndChar of+ Just endChar | isSelectChar endChar -> do+ textIterForwardFindChar end (not.isSelectChar) Nothing+ return ()+ _ -> return ()+ textBufferSelectRange buffer start end+ return True+ _ -> return False+ (GetTextPopup mbTpm) <- reflectIDE (triggerEvent ideR (GetTextPopup Nothing)) ideR+ case mbTpm of+ Just tpm -> sv `onPopulatePopup` (tpm ideR) >> return ()+ Nothing -> sysMessage Normal "SourceBuffer>> no text popup" >> return ()+ return (buf,[ConnectC cid]) + checkModTime :: IDEBuffer -> IDEM Bool checkModTime buf = do currentState' <- readIDE currentState case currentState' of IsShuttingDown -> return False- _ -> do- panes <- readIDE panes+ _ -> reifyIDE (\ideR -> do let name = paneName buf case fileName buf of Just fn -> do- exists <- liftIO $doesFileExist fn+ exists <- doesFileExist fn if exists then do- nmt <- liftIO $ getModificationTime fn- modTime' <- liftIO $ readIORef (modTime buf)+ nmt <- getModificationTime fn+ modTime' <- readIORef (modTime buf) case modTime' of- Nothing -> throwIDE $"checkModTime: time not set " ++ show (fileName buf)- Just mt -> do+ Nothing -> error $"checkModTime: time not set " ++ show (fileName buf)+ Just mt -> #if defined(mingw32_HOST_OS) || defined(__MINGW32__)- -- For some reason evaluating nmt /= mt causes corrupt fonts ?!?- return False+ if False #else- --message $"checkModTime " ++ name ++ " " ++ show mt ++ " " ++ show nmt- if nmt /= mt- then do- md <- liftIO $ messageDialogNew- Nothing []- MessageQuestion- ButtonsYesNo- ("File has changed on disk " ++ name ++ " Revert?")- resp <- liftIO $ dialogRun md- case resp of- ResponseYes -> do- revert buf- liftIO $ widgetHide md- return False- ResponseNo -> liftIO $ do- writeIORef (modTime buf) (Just nmt)- widgetHide md- return True- _ -> do return False- else return False+ if nmt /= mt -- Fonts get messed up under windows when adding this line.+ -- Praises to whoever finds out what happens and how to fix this #endif+ then do+ md <- messageDialogNew+ Nothing []+ MessageQuestion+ ButtonsYesNo+ ("File \"" ++ name ++ "\" has changed on disk. Load file from disk?")+ resp <- dialogRun md+ case resp of+ ResponseYes -> do+ reflectIDE (revert buf) ideR+ liftIO $ widgetHide md+ return False+ ResponseNo -> do+ writeIORef (modTime buf) (Just nmt)+ widgetHide md+ return True+ _ -> do return False+ else return False else return False- Nothing -> return False+ Nothing -> return False) setModTime :: IDEBuffer -> IDEAction setModTime buf = do- panes <- readIDE panes let name = paneName buf case fileName buf of Nothing -> return ()@@ -505,7 +584,6 @@ revert buf = do useCandy <- getCandyState ct <- readIDE candy- panes <- readIDE panes let name = paneName buf case fileName buf of Nothing -> return ()@@ -565,18 +643,9 @@ markLabelAsChanged :: Notebook -> IDEBuffer -> IO () markLabelAsChanged nb buf = do- gtkbuf <- textViewGetBuffer (sourceView buf)- modified <- textBufferGetModified gtkbuf- mbText <- notebookGetTabLabelText nb (scrolledWindow buf)- label <- labelNew Nothing- labelSetUseMarkup label True- case mbText of- Nothing -> return ()- Just text -> labelSetMarkup label- (if modified- then "<span foreground=\"red\">" ++ text ++ "</span>"- else text)- notebookSetTabLabel nb (scrolledWindow buf) label+ gtkbuf <- textViewGetBuffer (sourceView buf)+ modified <- textBufferGetModified gtkbuf+ markLabel nb (getTopWidget buf) modified inBufContext' :: alpha -> IDEBuffer -> (Notebook -> TextBuffer -> IDEBuffer -> Int -> IDEM alpha) -> IDEM alpha inBufContext' def ideBuf f = do@@ -608,10 +677,8 @@ fileSaveBuffer :: Bool -> Notebook -> TextBuffer -> IDEBuffer -> Int -> IDEM Bool fileSaveBuffer query nb gtkbuf ideBuf i = do ideR <- ask- window <- readIDE window- bufs <- readIDE panes+ window <- getMainWindow prefs <- readIDE prefs- paneMap <- readIDE paneMap bs <- getCandyState candy <- readIDE candy (panePath,connects) <- guiPropertiesFromName (paneName ideBuf)@@ -677,7 +744,7 @@ buf <- textViewGetBuffer $ sourceView ideBuf text <- getCandylessText ct buf let text' = if removeTBlanks- then unlines $map removeTrailingBlanks $lines text+ then unlines $ map removeTrailingBlanks $lines text else text succ <- catch (do UTF8.writeFile fn text'; return True) (\e -> do@@ -691,19 +758,18 @@ fileSave :: Bool -> IDEM Bool fileSave query = inActiveBufContext' False $ fileSaveBuffer query -fileSaveAll :: IDEM Bool-fileSaveAll = do- bufs <- allBuffers- results <- forM bufs (\buf -> inBufContext' False buf (fileSaveBuffer False))+fileSaveAll :: (IDEBuffer -> IDEM Bool) -> IDEM Bool+fileSaveAll filterFunc = do+ bufs <- allBuffers+ filtered <- filterM filterFunc bufs+ results <- forM filtered (\buf -> inBufContext' False buf (fileSaveBuffer False)) return $ True `elem` results -fileCheckBuffer :: Bool -> Notebook -> TextBuffer -> IDEBuffer -> Int -> IDEM Bool-fileCheckBuffer query nb gtkbuf ideBuf i = do+fileCheckBuffer :: Notebook -> TextBuffer -> IDEBuffer -> Int -> IDEM Bool+fileCheckBuffer nb gtkbuf ideBuf i = do ideR <- ask- window <- readIDE window- bufs <- readIDE panes+ window <- getMainWindow prefs <- readIDE prefs- paneMap <- readIDE paneMap bs <- getCandyState candy <- readIDE candy (panePath,connects) <- guiPropertiesFromName (paneName ideBuf)@@ -712,22 +778,23 @@ case mbpage of Nothing -> throwIDE "fileCheck: Page not found" Just page ->- if isJust mbfn && query == False+ if isJust mbfn then do modifiedOnDisk <- checkModTime ideBuf -- The user is given option to reload modifiedInBuffer <- liftIO $ textBufferGetModified gtkbuf return (modifiedOnDisk || modifiedInBuffer) else return False -fileCheckAll :: IDEM Bool-fileCheckAll = do+fileCheckAll :: (IDEBuffer -> IDEM Bool) -> IDEM Bool+fileCheckAll filterFunc = do bufs <- allBuffers- results <- forM bufs (\buf -> inBufContext' False buf (fileCheckBuffer False))+ filtered <- filterM filterFunc bufs+ results <- forM filtered (\buf -> inBufContext' False buf fileCheckBuffer) return $ True `elem` results fileNew :: IDEAction fileNew = do prefs <- readIDE prefs- pp <- getActivePanePathOrStandard (sourcePanePath prefs)+ pp <- getBestPathForId "*Buffer" newTextBuffer pp "Unnamed" Nothing return () @@ -736,9 +803,7 @@ fileClose' :: Notebook -> TextBuffer -> IDEBuffer -> Int -> IDEM Bool fileClose' nb gtkbuf currentBuffer i = do- window <- readIDE window- bufs <- readIDE panes- paneMap <- readIDE paneMap+ window <- getMainWindow cancel <- reifyIDE $ \ideR -> do modified <- textBufferGetModified gtkbuf if modified@@ -770,20 +835,19 @@ (addRecentlyUsedFile (fromJust $ fileName currentBuffer)) return True --fileCloseAll :: IDEM Bool-fileCloseAll = do+fileCloseAll :: (IDEBuffer -> IDEM Bool) -> IDEM Bool+fileCloseAll filterFunc = do bufs <- allBuffers- if null bufs+ filtered <- filterM filterFunc bufs+ if null filtered then return True else do- makeActive (head bufs)+ makeActive (head filtered) r <- fileClose if r- then fileCloseAll+ then fileCloseAll filterFunc else return False - fileCloseAllButPackage :: IDEAction fileCloseAllButPackage = do mbActivePack <- readIDE activePack@@ -807,7 +871,7 @@ fileOpen :: IDEAction fileOpen = do- window <- readIDE window+ window <- getMainWindow prefs <- readIDE prefs mbFileName <- liftIO $ do dialog <- fileChooserDialogNew@@ -861,7 +925,7 @@ [] -> reallyOpen prefs fpc where reallyOpen prefs fpc = do- pp <- standardSourcePanePath+ pp <- getBestPathForId "*Buffer" newTextBuffer pp (takeFileName fpc) (Just fpc) return () @@ -1072,8 +1136,8 @@ 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+ modifyIDE_ (\ide -> ide{recentFiles = take 12 (fp : recentFiles')})+ triggerEventIDE UpdateRecent return () removeRecentlyUsedFile :: FilePath -> IDEAction@@ -1082,9 +1146,64 @@ 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+ modifyIDE_ (\ide -> ide{recentFiles = filter (\e -> e /= fp) recentFiles'})+ triggerEventIDE UpdateRecent return () +selectedText :: IDEM (Maybe String)+selectedText = do+ candy' <- readIDE candy+ inActiveBufContext Nothing $ \_ gtkbuf currentBuffer _ -> do+ hasSelection <- liftIO $ textBufferHasSelection gtkbuf+ if hasSelection+ then do+ (i1,i2) <- liftIO $ textBufferGetSelectionBounds gtkbuf+ text <- getCandylessPart candy' gtkbuf i1 i2+ return $ Just text+ else return Nothing +selectedLocation :: IDEM (Maybe (Int, Int))+selectedLocation = do+ useCandy <- getCandyState+ candy' <- readIDE candy+ inActiveBufContext Nothing $ \_ gtkbuf currentBuffer _ -> do+ (start, _) <- liftIO $ textBufferGetSelectionBounds gtkbuf+ line <- textIterGetLine start+ lineOffset <- textIterGetLineOffset start+ res <- if useCandy+ then positionFromCandy candy' gtkbuf (line, lineOffset)+ else return (line, lineOffset)+ return $ Just res++-- " ++ ++ ++ alpha++insertTextAfterSelection :: String -> IDEAction+insertTextAfterSelection str = do+ candy' <- readIDE candy+ useCandy <- getCandyState+ inActiveBufContext () $ \_ gtkbuf currentBuffer _ -> do+ hasSelection <- liftIO $ textBufferHasSelection gtkbuf+ when hasSelection $ liftIO $ do+ realString <- if useCandy then stringToCandy candy' str else return str+ (_,i) <- textBufferGetSelectionBounds gtkbuf+ mark <- textBufferCreateMark gtkbuf Nothing i True+ textBufferInsert gtkbuf i realString+ i1 <- textBufferGetIterAtMark gtkbuf mark+ i2 <- textIterCopy i1+ textIterForwardChars i2 (length str)+ textBufferSelectRange gtkbuf i1 i2++selectedModuleName :: IDEM (Maybe String)+selectedModuleName = do+ candy' <- readIDE candy+ inActiveBufContext' Nothing $ \_ gtkbuf currentBuffer _ -> do+ case fileName currentBuffer of+ Just filePath -> do+ text <- liftIO $ getCandylessText candy' gtkbuf+ parseResult <- parseHeader filePath text+ case parseResult of+ Just HsModule{ hsmodName = Just name }+ -> return $ Just $ moduleNameString (unLoc name)+ _ -> return Nothing+ Nothing -> return Nothing
+ src/IDE/Pane/Trace.hs view
@@ -0,0 +1,327 @@+{-# OPTIONS_GHC -XRecordWildCards -XTypeSynonymInstances -XMultiParamTypeClasses+ -XDeriveDataTypeable #-}+-----------------------------------------------------------------------------+--+-- Module : IDE.Pane.Trace+-- Copyright : 2007-2009 Juergen Nicklisch-Franken, Hamish Mackenzie+-- License : GPL+--+-- Maintainer : maintainer@leksah.org+-- Stability : provisional+-- Portability :+--+-- |+--+-----------------------------------------------------------------------------++module IDE.Pane.Trace (+ IDETrace+, TraceState+, showTrace+, showTrace'+, fillTraceList+) where++import Graphics.UI.Gtk+import Data.Typeable (Typeable(..))+import IDE.Core.State+import Control.Monad.Reader+import IDE.Debug+ (debugForward, debugBack, debugCommand', debugHistory)+import IDE.Tool (ToolOutput(..))+import IDE.LogRef (srcSpanParser)+import Debug.Trace (trace)+import Text.ParserCombinators.Parsec+ (anyChar,+ skipMany,+ (<|>),+ optional,+ eof,+ try,+ parse,+ (<?>),+ noneOf,+ many,+ CharParser)+import qualified Text.ParserCombinators.Parsec.Token as P+ (integer, whiteSpace, colon, symbol, makeTokenParser)+import Text.ParserCombinators.Parsec.Language (emptyDef)+import GHC (SrcSpan(..))+import Outputable (ppr, showSDoc)+import Graphics.UI.Gtk.Gdk.Events (Event(..))+import Graphics.UI.Gtk.General.Enums (MouseButton(..))+++-- | A debugger pane description+--+data IDETrace = IDETrace {+ scrolledView :: ScrolledWindow+, treeView :: TreeView+, tracepoints :: TreeStore TraceHist+} deriving Typeable++data TraceState = TraceState {+} deriving(Eq,Ord,Read,Show,Typeable)++data TraceHist = TraceHist {+ thSelected :: Bool,+ thIndex :: Int,+ thFunction :: String,+ thPosition :: SrcSpan+ }++instance IDEObject IDETrace++instance Pane IDETrace IDEM+ where+ primPaneName _ = "Trace"+ getAddedIndex _ = 0+ getTopWidget = castToWidget . scrolledView+ paneId b = "*Trace"+ makeActive pane = activatePane pane []+ close = closePane++instance RecoverablePane IDETrace TraceState IDEM where+ saveState p = do+ return (Just TraceState)+ recoverState pp TraceState = do+ nb <- getNotebook pp+ newPane pp nb builder+ return ()++showTrace :: IDEAction+showTrace = do+ debugHistory+ m <- getTrace+ liftIO $ bringPaneToFront m+ liftIO $ widgetGrabFocus (treeView m)++showTrace' :: PanePath -> IDEAction+showTrace' pp = do+ m <- getTrace' pp+ liftIO $ bringPaneToFront m+ liftIO $ widgetGrabFocus (treeView m)+++getTrace :: IDEM IDETrace+getTrace = do+ mbTrace <- getPane+ case mbTrace of+ Nothing -> do+ pp <- getBestPathForId "*Trace"+ nb <- getNotebook pp+ newPane pp nb builder+ mbTrace <- getPane+ case mbTrace of+ Nothing -> throwIDE "Can't init trace"+ Just m -> return m+ Just m -> return m++getTrace' :: PanePath -> IDEM IDETrace+getTrace' pp = do+ mbTrace <- getPane+ case mbTrace of+ Nothing -> do+ layout <- getLayout+ nb <- getNotebook (getBestPanePath pp layout)+ newPane pp nb builder+ mbTrace <- getPane+ case mbTrace of+ Nothing -> throwIDE "Can't init trace"+ Just m -> return m+ Just m -> return m++builder :: PanePath ->+ Notebook ->+ Window ->+ IDERef ->+ IO (IDETrace,Connections)+builder pp nb windows ideR = do+ tracepoints <- treeStoreNew []+ treeView <- treeViewNew+ treeViewSetModel treeView tracepoints++ renderer0 <- cellRendererToggleNew+ col0 <- treeViewColumnNew+ treeViewColumnSetTitle col0 ""+ treeViewColumnSetSizing col0 TreeViewColumnAutosize+ treeViewColumnSetResizable col0 False+ treeViewColumnSetReorderable col0 True+ treeViewAppendColumn treeView col0+ cellLayoutPackStart col0 renderer0 False+ cellLayoutSetAttributes col0 renderer0 tracepoints+ $ \row -> [ cellToggleActive := thSelected row]++ renderer1 <- cellRendererTextNew+ col1 <- treeViewColumnNew+ treeViewColumnSetTitle col1 "Index"+ treeViewColumnSetSizing col1 TreeViewColumnAutosize+ treeViewColumnSetResizable col1 True+ treeViewColumnSetReorderable col1 True+ treeViewAppendColumn treeView col1+ cellLayoutPackStart col1 renderer1 False+ cellLayoutSetAttributes col1 renderer1 tracepoints+ $ \row -> [ cellText := show (thIndex row)]++ renderer2 <- cellRendererTextNew+ col2 <- treeViewColumnNew+ treeViewColumnSetTitle col2 "Function"+ treeViewColumnSetSizing col2 TreeViewColumnAutosize+ treeViewColumnSetResizable col2 True+ treeViewColumnSetReorderable col2 True+ treeViewAppendColumn treeView col2+ cellLayoutPackStart col2 renderer2 False+ cellLayoutSetAttributes col2 renderer2 tracepoints+ $ \row -> [ cellText := thFunction row]++ renderer3 <- cellRendererTextNew+ col3 <- treeViewColumnNew+ treeViewColumnSetTitle col3 "Position"+ treeViewColumnSetSizing col3 TreeViewColumnAutosize+ treeViewColumnSetResizable col3 True+ treeViewColumnSetReorderable col3 True+ treeViewAppendColumn treeView col3+ cellLayoutPackStart col3 renderer3 False+ cellLayoutSetAttributes col3 renderer3 tracepoints+ $ \row -> [ cellText := (showSDoc . ppr) (thPosition row)]++ treeViewSetHeadersVisible treeView True+ sel <- treeViewGetSelection treeView+ treeSelectionSetMode sel SelectionSingle++ scrolledView <- scrolledWindowNew Nothing Nothing+ containerAdd scrolledView treeView+ scrolledWindowSetPolicy scrolledView PolicyAutomatic PolicyAutomatic++ let pane = IDETrace scrolledView treeView tracepoints++ cid1 <- treeView `afterFocusIn`+ (\_ -> do reflectIDE (makeActive pane) ideR ; return True)+ sel `onSelectionChanged` do+ sel <- getSelectedTracepoint treeView tracepoints+ case sel of+ Just ref -> return () -- TODO reflectIDE (selectRef (Just ref)) ideR+ Nothing -> return ()+ treeView `onButtonPress` (traceViewPopup ideR tracepoints treeView)+ return (pane,[ConnectC cid1])++fillTraceList :: IDEAction+fillTraceList = do+ currentHist' <- readIDE currentHist+ mbTraces <- getPane+ case mbTraces of+ Nothing -> return ()+ Just tracePane -> debugCommand' ":history" (\to -> liftIO $ postGUIAsync $ do+ let parseRes = parse tracesParser "" (selectString to)+ r <- case parseRes of+ Left err -> trace ("trace parse error " ++ show err ++ "\ninput: " ++ selectString to)+ $ return []+ Right traces -> return traces+ treeStoreClear (tracepoints tracePane)+ let r' = map (\h@(TraceHist _ i _ _) -> if i == currentHist'+ then h{thSelected = True}+ else h) r+ mapM_ (insertTrace (tracepoints tracePane))+ (zip r' [0..length r']))+ where+ insertTrace treeStore (tr,index) = treeStoreInsert treeStore [] index tr++selectString :: [ToolOutput] -> String+selectString (ToolOutput str:r) = '\n' : str ++ selectString r+selectString (_:r) = selectString r+selectString [] = ""++getSelectedTracepoint :: TreeView+ -> TreeStore TraceHist+ -> IO (Maybe TraceHist)+getSelectedTracepoint treeView treeStore = do+ treeSelection <- treeViewGetSelection treeView+ paths <- treeSelectionGetSelectedRows treeSelection+ case paths of+ a:r -> do+ val <- treeStoreGetValue treeStore a+ return (Just val)+ _ -> return Nothing++selectStrings :: [ToolOutput] -> [String]+selectStrings (ToolOutput str:r) = str : selectStrings r+selectStrings (_:r) = selectStrings r+selectStrings [] = []++traceViewPopup :: IDERef+ -> TreeStore TraceHist+ -> TreeView+ -> Event+ -> IO (Bool)+traceViewPopup ideR store treeView (Button _ click _ _ _ _ button _ _)+ = do+ if button == RightButton+ then do+ theMenu <- menuNew+ item1 <- menuItemNewWithLabel "Back"+ item1 `onActivateLeaf` reflectIDE debugBack ideR+ sep1 <- separatorMenuItemNew+ item2 <- menuItemNewWithLabel "Forward"+ item2 `onActivateLeaf` (reflectIDE debugForward ideR)+ item3 <- menuItemNewWithLabel "Update"+ item3 `onActivateLeaf` (reflectIDE fillTraceList ideR)+ mapM_ (menuShellAppend theMenu) [castToMenuItem item1, castToMenuItem sep1,+ castToMenuItem item2, castToMenuItem item3]+ menuPopup theMenu Nothing+ widgetShowAll theMenu+ return True+ else return False+-- if button == LeftButton && click == DoubleClick+-- then do sel <- getSelectedBreakpoint treeView store+-- case sel of+-- Just ref -> reflectIDE (setCurrentBreak (Just ref)) ideR+-- otherwise -> sysMessage Normal "Debugger>> breakpointViewPopup: no selection2"+-- return True+-- else return False+traceViewPopup _ _ _ _ = throwIDE "breakpointViewPopup wrong event type"+++tracesParser :: CharParser () [TraceHist]+tracesParser = try (do+ whiteSpace+ symbol "Empty history."+ skipMany anyChar+ eof+ return [])+ <|> do+ traces <- many (try traceParser)+ whiteSpace+ symbol "<end of history>"+ eof+ return traces+ <|> do+ whiteSpace+ symbol "Not stopped at a breakpoint"+ skipMany anyChar+ eof+ return []+ <?>+ "traces parser"++traceParser :: CharParser () TraceHist+traceParser = do+ whiteSpace+ index <- int+ colon+ optional (symbol "\ESC[1m")+ function <- many (noneOf "(\ESC")+ optional (symbol "\ESC[0m")+ symbol "("+ span <- srcSpanParser+ symbol ")"+ return (TraceHist False index function span)+ <?> "trace parser"++lexer = P.makeTokenParser emptyDef+colon = P.colon lexer+symbol = P.symbol lexer+whiteSpace = P.whiteSpace lexer+int = fmap fromInteger $ P.integer lexer+++
+ src/IDE/Pane/Variables.hs view
@@ -0,0 +1,332 @@+{-# OPTIONS_GHC -XRecordWildCards -XTypeSynonymInstances -XMultiParamTypeClasses+ -XDeriveDataTypeable #-}+-----------------------------------------------------------------------------+--+-- Module : IDE.Pane.Variables+-- Copyright : 2007-2009 Juergen Nicklisch-Franken, Hamish Mackenzie+-- License : GPL+--+-- Maintainer : maintainer@leksah.org+-- Stability : provisional+-- Portability :+--+-- |+--+-----------------------------------------------------------------------------++module IDE.Pane.Variables (+ IDEVariables+, VariablesState+, showVariables+, showVariables'+, fillVariablesList+) where++import Graphics.UI.Gtk+import Data.Typeable (Typeable(..))+import IDE.Core.State+import Control.Monad.Reader+import IDE.Debug (debugCommand')+import IDE.Tool (ToolOutput(..))+import Text.ParserCombinators.Parsec+ (anyChar,+ lookAhead,+ eof,+ (<|>),+ try,+ (<?>),+ char,+ noneOf,+ many,+ CharParser(..),+ parse)+import qualified Text.ParserCombinators.Parsec.Token as P+ (whiteSpace, symbol, makeTokenParser)+import Text.ParserCombinators.Parsec.Language (emptyDef)+import Graphics.UI.Gtk.Gdk.Events (Event(..))+import Graphics.UI.Gtk.General.Enums+ (Click(..), MouseButton(..))++-- | A variables pane description+--+data IDEVariables = IDEVariables {+ scrolledView :: ScrolledWindow+, treeView :: TreeView+, variables :: TreeStore VarDescription+} deriving Typeable++data VarDescription = VarDescription {+ varName :: String+, varType :: String+, varValue :: String}++data VariablesState = VariablesState {+} deriving(Eq,Ord,Read,Show,Typeable)++instance IDEObject IDEVariables++instance Pane IDEVariables IDEM+ where+ primPaneName _ = "Variables"+ getAddedIndex _ = 0+ getTopWidget = castToWidget . scrolledView+ paneId b = "*Variables"+ makeActive pane = activatePane pane []+ close = closePane++instance RecoverablePane IDEVariables VariablesState IDEM where+ saveState p = do+ return (Just VariablesState)+ recoverState pp VariablesState = do+ nb <- getNotebook pp+ newPane pp nb builder+ return ()++showVariables :: IDEAction+showVariables = do+ m <- getVariables+ liftIO $ bringPaneToFront m+ liftIO $ widgetGrabFocus (treeView m)++getVariables :: IDEM IDEVariables+getVariables = do+ mbVar <- getPane+ case mbVar of+ Nothing -> do+ pp <- getBestPathForId "*Variables"+ nb <- getNotebook pp+ newPane pp nb builder+ mbVar <- getPane+ case mbVar of+ Nothing -> throwIDE "Can't init variables"+ Just m -> return m+ Just m -> return m++showVariables' :: PanePath -> IDEAction+showVariables' pp = do+ m <- getVariables' pp+ liftIO $ bringPaneToFront m+ liftIO $ widgetGrabFocus (treeView m)++getVariables' :: PanePath -> IDEM IDEVariables+getVariables' pp = do+ mbVar <- getPane+ case mbVar of+ Nothing -> do+ layout <- getLayout+ nb <- getNotebook (getBestPanePath pp layout)+ newPane pp nb builder+ mbVar <- getPane+ case mbVar of+ Nothing -> throwIDE "Can't init variables"+ Just m -> return m+ Just m -> return m++builder :: PanePath ->+ Notebook ->+ Window ->+ IDERef ->+ IO (IDEVariables, Connections)+builder pp nb windows ideR = do+ variables <- treeStoreNew []+ treeView <- treeViewNew+ treeViewSetModel treeView variables++ renderer1 <- cellRendererTextNew+ col1 <- treeViewColumnNew+ treeViewColumnSetTitle col1 "Name"+ treeViewColumnSetSizing col1 TreeViewColumnAutosize+ treeViewColumnSetResizable col1 True+ treeViewColumnSetReorderable col1 True+ treeViewAppendColumn treeView col1+ cellLayoutPackStart col1 renderer1 False+ cellLayoutSetAttributes col1 renderer1 variables+ $ \row -> [ cellText := varName row]++ renderer2 <- cellRendererTextNew+ col2 <- treeViewColumnNew+ treeViewColumnSetTitle col2 "Type"+ treeViewColumnSetSizing col2 TreeViewColumnAutosize+ treeViewColumnSetResizable col2 True+ treeViewColumnSetReorderable col2 True+ treeViewAppendColumn treeView col2+ cellLayoutPackStart col2 renderer2 False+ cellLayoutSetAttributes col2 renderer2 variables+ $ \row -> [ cellText := varType row]++ renderer3 <- cellRendererTextNew+ col3 <- treeViewColumnNew+ treeViewColumnSetTitle col3 "Value"+ treeViewColumnSetSizing col3 TreeViewColumnAutosize+ treeViewColumnSetResizable col3 True+ treeViewColumnSetReorderable col3 True+ treeViewAppendColumn treeView col3+ cellLayoutPackStart col3 renderer3 False+ cellLayoutSetAttributes col3 renderer3 variables+ $ \row -> [ cellText := varValue row]++ treeViewSetHeadersVisible treeView True+ sel <- treeViewGetSelection treeView+ treeSelectionSetMode sel SelectionSingle++ scrolledView <- scrolledWindowNew Nothing Nothing+ containerAdd scrolledView treeView+ scrolledWindowSetPolicy scrolledView PolicyAutomatic PolicyAutomatic++ let pane = IDEVariables scrolledView treeView variables+ treeView `onButtonPress` (variablesViewPopup ideR variables treeView)+ cid1 <- treeView `afterFocusIn`+ (\_ -> do reflectIDE (makeActive pane) ideR ; return True)+ return (pane,[ConnectC cid1])+++fillVariablesList :: IDEAction+fillVariablesList = do+ mbVariables <- getPane+ case mbVariables of+ Nothing -> return ()+ Just var -> debugCommand' ":show bindings" (\to -> liftIO $ postGUIAsync+ $ (do+ case parse variablesParser "" (selectString to) of+ Left e -> sysMessage Normal (show e)+ Right triples -> do+ treeStoreClear (variables var)+ mapM_ (insertBreak (variables var))+ (zip triples [0..length triples])))+ where+ insertBreak treeStore (v,index) = treeStoreInsert treeStore [] index v++selectString :: [ToolOutput] -> String+selectString (ToolOutput str:r) = '\n' : str ++ selectString r+selectString (_:r) = selectString r+selectString [] = ""++getSelectedVariable :: TreeView+ -> TreeStore VarDescription+ -> IO (Maybe (VarDescription,TreePath))+getSelectedVariable treeView treeStore = do+ treeSelection <- treeViewGetSelection treeView+ paths <- treeSelectionGetSelectedRows treeSelection+ case paths of+ a:r -> do+ val <- treeStoreGetValue treeStore a+ return (Just (val,a))+ _ -> return Nothing++variablesParser :: CharParser () [VarDescription]+variablesParser = do+ whiteSpace+ r <- many variableParser+ eof+ return r++variableParser :: CharParser () VarDescription+variableParser = do+ whiteSpace+ varName <- many (noneOf ":")+ symbol "::"+ typeStr <- many (noneOf "=")+ char '='+ value <- many (do+ noneOf "\n"+ <|> try (do+ r <- char '\n'+ lookAhead (char ' ')+ return r))++ return (VarDescription varName typeStr value)+ <?> "variableParser"++valueParser :: CharParser () String+valueParser = do+ whiteSpace+ many (noneOf "=")+ char '='+ value <- many anyChar+ return (value)+ <?> "valueParser"++typeParser :: CharParser () String+typeParser = do+ whiteSpace+ many (noneOf ":")+ symbol "::"+ typeStr <- many anyChar+ return typeStr+ <?> "typeParser"+++lexer = P.makeTokenParser emptyDef+symbol = P.symbol lexer+whiteSpace = P.whiteSpace lexer+++variablesViewPopup :: IDERef+ -> TreeStore VarDescription+ -> TreeView+ -> Event+ -> IO (Bool)+variablesViewPopup ideR store treeView (Button _ click _ _ _ _ button _ _)+ = do+ if button == RightButton+ then do+ theMenu <- menuNew+ item1 <- menuItemNewWithLabel "Force"+ item1 `onActivateLeaf` do+ mbSel <- getSelectedVariable treeView store+ case mbSel of+ Just (varDescr,path) -> reflectIDE (forceVariable varDescr path store) ideR+ otherwise -> return ()+ sep1 <- separatorMenuItemNew+ item2 <- menuItemNewWithLabel "Print"+ item2 `onActivateLeaf` do+ mbSel <- getSelectedVariable treeView store+ case mbSel of+ Just (varDescr,path) -> reflectIDE (printVariable varDescr path store) ideR+ otherwise -> return ()+ item3 <- menuItemNewWithLabel "Update"+ item3 `onActivateLeaf` (postGUIAsync (reflectIDE fillVariablesList ideR))+ mapM_ (menuShellAppend theMenu) [castToMenuItem item1,+ castToMenuItem item2, castToMenuItem sep1, castToMenuItem item3]+ menuPopup theMenu Nothing+ widgetShowAll theMenu+ return True+ else if button == LeftButton && click == DoubleClick+ then do mbSel <- getSelectedVariable treeView store+ case mbSel of+ Just (varDescr,path) -> reflectIDE (forceVariable varDescr path store) ideR+ otherwise -> return ()+ return True+ else return False+variablesViewPopup _ _ _ _ = throwIDE "variablesViewPopup wrong event type"++forceVariable :: VarDescription -> TreePath -> TreeStore VarDescription -> IDEAction+forceVariable varDescr path treeStore = do+ debugCommand' (":force " ++ (varName varDescr)) (\to -> liftIO $ postGUIAsync (do+ case parse valueParser "" (selectString to) of+ Left e -> sysMessage Normal (show e)+ Right value -> do+ var <- treeStoreGetValue treeStore path+ treeStoreSetValue treeStore path var{varValue = value}))+ debugCommand' (":type " ++ (varName varDescr)) (\to -> liftIO $ postGUIAsync (do+ case parse typeParser "" (selectString to) of+ Left e -> sysMessage Normal (show e)+ Right typ -> do+ var <- treeStoreGetValue treeStore path+ treeStoreSetValue treeStore path var{varType = typ}))++printVariable :: VarDescription -> TreePath -> TreeStore VarDescription -> IDEAction+printVariable varDescr path treeStore = do+ debugCommand' (":print " ++ (varName varDescr)) (\to -> liftIO $ postGUIAsync (do+ case parse valueParser "" (selectString to) of+ Left e -> sysMessage Normal (show e)+ Right value -> do+ var <- treeStoreGetValue treeStore path+ treeStoreSetValue treeStore path var{varValue = value}))+ debugCommand' (":type " ++ (varName varDescr)) (\to -> liftIO $ postGUIAsync (do+ case parse typeParser "" (selectString to) of+ Left e -> sysMessage Normal (show e)+ Right typ -> do+ var <- treeStoreGetValue treeStore path+ treeStoreSetValue treeStore path var{varType = typ}))+
src/IDE/SaveSession.hs view
@@ -1,4 +1,4 @@-{-# OPTIONS_GHC -XTypeSynonymInstances #-}+{-# OPTIONS_GHC -XTypeSynonymInstances -XScopedTypeVariables #-} ----------------------------------------------------------------------------- -- -- Module : IDE.SaveSession@@ -47,10 +47,16 @@ import IDE.Pane.Preferences import IDE.Pane.PackageFlags import IDE.Pane.Search+import IDE.Pane.Grep+import IDE.Pane.Breakpoints+import IDE.Pane.Trace+import IDE.Pane.Variables import IDE.Find import System.Time (getClockTime) import IDE.Package (activatePackage,deactivatePackage) import Data.List (foldl')+import IDE.Pane.Errors (ErrorsState(..))+import Control.Exception (SomeException(..)) -- --------------------------------------------------------------------- -- All pane types must be in here !@@ -64,18 +70,28 @@ | PrefsSt PrefsState | FlagsSt FlagsState | SearchSt SearchState- deriving(Eq,Ord,Read,Show)+ | GrepSt GrepState+ | BreakpointsSt BreakpointsState+ | TraceSt TraceState+ | VariablesSt VariablesState+ | ErrorsSt ErrorsState+ deriving(Eq,Ord,Read,Show) asPaneState :: RecoverablePane alpha beta gamma => beta -> PaneState-asPaneState s | isJust ((cast s) :: Maybe BufferState) = BufferSt (fromJust $ cast s)-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 BufferState) = BufferSt (fromJust $ cast s)+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 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)-asPaneState s = error "SaveSession>>asPaneState incomplete cast"+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)+asPaneState s | isJust ((cast s) :: Maybe GrepState) = GrepSt (fromJust $ cast s)+asPaneState s | isJust ((cast s) :: Maybe BreakpointsState) = BreakpointsSt (fromJust $ cast s)+asPaneState s | isJust ((cast s) :: Maybe TraceState) = TraceSt (fromJust $ cast s)+asPaneState s | isJust ((cast s) :: Maybe VariablesState) = VariablesSt (fromJust $ cast s)+asPaneState s | isJust ((cast s) :: Maybe ErrorsState) = ErrorsSt (fromJust $ cast s)+asPaneState s = error "SaveSession>>asPaneState incomplete cast" recover :: PanePath -> PaneState -> IDEAction recover pp (BufferSt p) = recoverState pp p@@ -86,7 +102,11 @@ recover pp (PrefsSt p) = recoverState pp p recover pp (FlagsSt p) = recoverState pp p recover pp (SearchSt p) = recoverState pp p-+recover pp (GrepSt p) = recoverState pp p+recover pp (BreakpointsSt p) = recoverState pp p+recover pp (TraceSt p) = recoverState pp p+recover pp (VariablesSt p) = recoverState pp p+recover pp (ErrorsSt p) = recoverState pp p -- --------------------------------------------------------------------- @@ -96,12 +116,13 @@ sessionClosePane :: IDEAction sessionClosePane = do- activePane' <- readIDE activePane+ activePane' <- getActivePane case activePane' of Nothing -> return () Just (pn,_) -> do (PaneC p) <- paneFromName pn close p+ return () data SessionState = SessionState { saveTime :: String@@ -118,7 +139,7 @@ defaultLayout = SessionState { saveTime = ""- , layoutS = TerminalP (Just TopP) (-1)+ , layoutS = TerminalP Map.empty (Just TopP) (-1) Nothing Nothing , population = [] , windowSize = (1024,768) , activePackage = Nothing@@ -132,7 +153,7 @@ , caseSensitive = False , entireWord = False , wrapAround = True- , backward = False+ , regex = False , lineNr = 1}) , recentOpenedFiles = [] , recentOpenedPackages = []@@ -216,12 +237,18 @@ then ideMessage Normal "Forget this session" else do sysMessage Normal "Now saving session"- wdw <- readIDE window- layout <- getLayout+ bufs <- allBuffers+ case filter (\b -> bufferName b == "_Eval.hs") bufs of+ [buf] -> liftIO $ do+ gtkbuf <- textViewGetBuffer (sourceView buf)+ textBufferSetModified gtkbuf False+ _ -> return ()+ wdw <- getMainWindow+ layout <- mkLayout population <- getPopulation size <- liftIO $ windowGetSize wdw active <- getActive- activePane' <- readIDE activePane+ activePane' <- getActivePane let activeP = case activePane' of Nothing -> Nothing Just (s,_) -> Just s@@ -245,7 +272,7 @@ saveSessionAsPrompt :: IDEAction saveSessionAsPrompt = do- window' <- readIDE window+ window' <- getMainWindow response <- liftIO $ do configFolder <- getConfigDir dialog <- fileChooserDialogNew@@ -273,7 +300,7 @@ loadSessionPrompt :: IDEAction loadSessionPrompt = do- window' <- readIDE window+ window' <- getMainWindow response <- liftIO $ do configFolder <- getConfigDir dialog <- fileChooserDialogNew@@ -305,28 +332,28 @@ deactivatePackage recentFiles' <- readIDE recentFiles recentPackages' <- readIDE recentPackages- b <- fileCloseAll+ b <- fileCloseAll (\_ -> return True) if b then do paneCloseAll viewCollapseAll recoverSession sessionPath- modifyIDE_ (\ide -> return ide{recentFiles = recentFiles', recentPackages = recentPackages'})+ modifyIDE_ (\ide -> ide{recentFiles = recentFiles', recentPackages = recentPackages'}) return () else return () paneCloseAll :: IDEAction paneCloseAll = do- panes' <- readIDE panes+ panes' <- getPanesSt mapM_ (\ (PaneC p) -> close p) (Map.elems panes') viewCollapseAll :: IDEAction viewCollapseAll = do- layout' <- readIDE layout+ layout' <- getLayout case layout' of- TerminalP _ _ -> return ()- VerticalP _ _ _ -> viewCollapse' [LeftP]- HorizontalP _ _ _ -> viewCollapse' [TopP]+ TerminalP {} -> return ()+ VerticalP _ _ _ -> viewCollapse' [SplitP LeftP]+ HorizontalP _ _ _ -> viewCollapse' [SplitP TopP] writeLayout :: FilePath -> SessionState -> IO () writeLayout fpath ls = writeFile fpath (showLayout ls layoutDescr)@@ -335,35 +362,45 @@ showLayout prefs prefsDesc = PP.render $ foldl' (\ doc (FDS _ printer _) -> doc PP.$+$ printer prefs) PP.empty prefsDesc -getLayout :: IDEM(PaneLayout)-getLayout = do- rawLayout <- readIDE layout+mkLayout :: IDEM(PaneLayout)+mkLayout = do+ rawLayout <- getLayout getLayout' rawLayout [] where getLayout' (HorizontalP l r _) pp = do- l2 <- getLayout' l (pp ++ [TopP])- r2 <- getLayout' r (pp ++ [BottomP])+ l2 <- getLayout' l (pp ++ [SplitP TopP])+ r2 <- getLayout' r (pp ++ [SplitP BottomP]) pane <- getPaned pp pos <- liftIO $ panedGetPosition pane return (HorizontalP l2 r2 pos) getLayout' (VerticalP l r _) pp = do- l2 <- getLayout' l (pp ++ [LeftP])- r2 <- getLayout' r (pp ++ [RightP])+ l2 <- getLayout' l (pp ++ [SplitP LeftP])+ r2 <- getLayout' r (pp ++ [SplitP RightP]) pane <- getPaned pp pos <- liftIO $ panedGetPosition pane return (VerticalP l2 r2 pos)- getLayout' (TerminalP _ _) pp = do+ getLayout' raw@(TerminalP {paneGroups = groups}) pp = do+ groups2 <- forM (Map.toAscList groups) $ \(group, g) -> do+ l <- getLayout' g (pp ++ [GroupP group])+ return (group, l) nb <- getNotebook pp showTabs <- liftIO $ notebookGetShowTabs nb pos <- liftIO $ notebookGetTabPos nb current <- liftIO $ notebookGetCurrentPage nb- return (TerminalP (if showTabs- then Just (posTypeToPaneDirection pos)- else Nothing) current)+ size <- case detachedId raw of+ Just _ -> do+ Just parent <- liftIO $ widgetGetParent nb+ liftIO $ fmap Just $ windowGetSize (castToWindow parent)+ Nothing -> return $ detachedSize raw+ return raw{+ paneGroups = Map.fromAscList groups2+ , paneTabs = if showTabs then Just (posTypeToPaneDirection pos) else Nothing+ , currentPage = current+ , detachedSize = size} getPopulation :: IDEM[(Maybe PaneState,PanePath)] getPopulation = do- paneMap <- readIDE paneMap+ paneMap <- getPaneMapSt mapM (\ (pn,v) -> do (PaneC p) <- paneFromName pn mbSt <- saveState p@@ -388,31 +425,35 @@ -- recoverSession :: FilePath -> IDEM (Bool,Bool)-recoverSession sessionPath = do- wdw <- readIDE window- 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 sessionSt)- setCurrentPages (layoutS sessionSt)- when (isJust (activePaneN sessionSt)) $ do- mbPane <- mbPaneFromName (fromJust (activePaneN sessionSt))- case mbPane of+recoverSession sessionPath = catchIDE (do+ wdw <- getMainWindow+ 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 ()- Just (PaneC p) -> makeActive p- setFindState ((snd . findbarState) sessionSt)- if toolbarVisibleS sessionSt- then showToolbar- else hideToolbar- if (fst . findbarState) sessionSt- then showFindbar- else hideFindbar- modifyIDE_ (\ide -> return ide{recentFiles = recentOpenedFiles sessionSt,- recentPackages = recentOpenedPackages sessionSt})- return (toolbarVisibleS sessionSt, (fst . findbarState) sessionSt)+ 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) sessionSt)+ if toolbarVisibleS sessionSt+ then showToolbar+ else hideToolbar+ if (fst . findbarState) sessionSt+ then showFindbar+ else hideFindbar+ modifyIDE_ (\ide -> ide{recentFiles = recentOpenedFiles sessionSt,+ recentPackages = recentOpenedPackages sessionSt})+ return (toolbarVisibleS sessionSt, (fst . findbarState) sessionSt))+ (\ (e :: SomeException) -> do+ sysMessage Normal (show e)+ return (True,True))+ readLayout :: FilePath -> IO SessionState readLayout sessionPath = do@@ -430,30 +471,41 @@ applyLayout :: PaneLayout -> IDEAction applyLayout layoutS = do- old <- readIDE layout+ old <- getLayout case old of- TerminalP _ _ -> applyLayout' layoutS []- otherwise -> throwIDE "apply Layout can only be allied to empty Layout"+ TerminalP {} -> applyLayout' layoutS []+ otherwise -> throwIDE "apply Layout can only be allied to empty Layout" where- applyLayout' (TerminalP Nothing _) pp = do- nb <- getNotebook pp- liftIO $notebookSetShowTabs nb False- applyLayout' (TerminalP (Just p) _) pp = do+ applyLayout' (TerminalP groups mbTabPos _ mbDetachedId mbDetachedSize) pp = do+ forM_ (Map.keys groups) $ \group -> viewNest' pp group nb <- getNotebook pp- liftIO $notebookSetShowTabs nb True- liftIO $notebookSetTabPos nb (paneDirectionToPosType p)+ case (mbDetachedId, mbDetachedSize) of+ (Just id, Just (width, height)) -> do+ mbPair <- viewDetach' pp id+ case mbPair of+ Nothing -> return ()+ Just (win,wid) -> do+ liftIO $ widgetShowAll win+ liftIO $ windowSetDefaultSize win width height+ _ -> return ()+ liftIO $notebookSetShowTabs nb (isJust mbTabPos)+ case mbTabPos of+ Just p -> liftIO $notebookSetTabPos nb (paneDirectionToPosType p)+ _ -> return ()+ forM_ (Map.toAscList groups) $ \(group, g) -> do+ applyLayout' g (pp ++ [GroupP group]) applyLayout' (VerticalP l r pos) pp = do viewSplit' pp Vertical pane <- getPaned pp liftIO $panedSetPosition pane pos- applyLayout' l (pp ++ [LeftP])- applyLayout' r (pp ++ [RightP])+ applyLayout' l (pp ++ [SplitP LeftP])+ applyLayout' r (pp ++ [SplitP RightP]) applyLayout' (HorizontalP t b pos) pp = do viewSplit' pp Horizontal pane <- getPaned pp liftIO $panedSetPosition pane pos- applyLayout' t (pp ++ [TopP])- applyLayout' b (pp ++ [BottomP])+ applyLayout' t (pp ++ [SplitP TopP])+ applyLayout' b (pp ++ [SplitP BottomP]) populate :: [(Maybe PaneState,PanePath)] -> IDEAction populate = mapM_ (\ (mbPs,pp) ->@@ -464,13 +516,16 @@ setCurrentPages :: PaneLayout -> IDEAction setCurrentPages layout = setCurrentPages' layout [] where- setCurrentPages' (HorizontalP t b _) p = do setCurrentPages' t (TopP : p)- 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- nb <- getNotebook (reverse p)- liftIO $ notebookSetCurrentPage nb ind+ setCurrentPages' (HorizontalP t b _) p = do setCurrentPages' t (SplitP TopP : p)+ setCurrentPages' b (SplitP BottomP : p)+ setCurrentPages' (VerticalP l r _) p = do setCurrentPages' l (SplitP LeftP : p)+ setCurrentPages' r (SplitP RightP : p)+ setCurrentPages' (TerminalP groups _ ind _ _) p = do+ forM_ (Map.toAscList groups) $ \(group, g) -> do+ setCurrentPages' g (GroupP group : p)+ when (ind >= 0) $ do+ nb <- getNotebook (reverse p)+ liftIO $ notebookSetCurrentPage nb ind
src/IDE/SourceCandy.hs view
@@ -15,10 +15,15 @@ module IDE.SourceCandy ( parseCandy -- :: FilePath -> IO alpha-, transformToCandy -- :: alpha -> TextBuffer -> IO ()-, transformFromCandy -- :: alpha -> TextBuffer -> IO ()-, keystrokeCandy -- :: alpha -> Maybe Char -> TextBuffer -> IO ()-, getCandylessText -- :: alpha -> TextBuffer -> IO String+, transformToCandy -- :: TextBuffer -> IO ()+, transformFromCandy -- :: TextBuffer -> IO ()+, keystrokeCandy -- :: Maybe Char -> TextBuffer -> IO ()+, getCandylessText -- :: TextBuffer -> IO String++, getCandylessPart -- :: CandyTable -> TextBuffer -> TextIter -> TextIter -> IO String+, stringToCandy -- :: CandyTable -> String -> IO String+, positionToCandy -- :: CandyTable -> TextBuffer -> (Int,Int) -> IO (Int,Int)+, positionFromCandy -- :: CandyTable -> TextBuffer -> (Int,Int) -> IO (Int,Int) ) where import Data.Char(chr)@@ -142,7 +147,7 @@ textBufferEndUserAction gtkbuf textBufferSetModified gtkbuf modified -getCandylessText :: CandyTable -> TextBuffer -> IO (String)+getCandylessText :: CandyTable -> TextBuffer -> IO String getCandylessText (CT(_,transformTableBack)) gtkbuf = do workBuffer <- textBufferNew Nothing i1 <- textBufferGetStartIter gtkbuf@@ -154,6 +159,58 @@ i2 <- textBufferGetEndIter workBuffer text2 <- textBufferGetText workBuffer i1 i2 True return text2++getCandylessPart :: CandyTable -> TextBuffer -> TextIter -> TextIter -> IO String+getCandylessPart (CT(_,transformTableBack)) gtkbuf i1 i2 = do+ workBuffer <- textBufferNew Nothing+ text1 <- textBufferGetText gtkbuf i1 i2 True+ textBufferSetText workBuffer text1+ mapM_ (\tbl -> replaceFrom workBuffer tbl 0) transformTableBack+ i1 <- textBufferGetStartIter workBuffer+ i2 <- textBufferGetEndIter workBuffer+ text2 <- textBufferGetText workBuffer i1 i2 True+ return text2++stringToCandy :: CandyTable -> String -> IO String+stringToCandy candyTable text = do+ workBuffer <- textBufferNew Nothing+ textBufferSetText workBuffer text+ transformToCandy candyTable workBuffer+ i1 <- textBufferGetStartIter workBuffer+ i2 <- textBufferGetEndIter workBuffer+ text2 <- textBufferGetText workBuffer i1 i2 True+ return text2++positionFromCandy :: CandyTable -> TextBuffer -> (Int,Int) -> IO (Int,Int)+positionFromCandy candyTable gtkbuf (line,column) = do+ i1 <- textBufferGetIterAtLine gtkbuf (max 0 (line - 1))+ i2 <- textIterCopy i1+ textIterForwardToLineEnd i2+ text <- textBufferGetText gtkbuf i1 i2 True+ workBuffer <- textBufferNew Nothing+ textBufferSetText workBuffer text+ i3 <- textBufferGetIterAtOffset workBuffer column+ mark <- textBufferCreateMark workBuffer Nothing i3 True+ transformFromCandy candyTable workBuffer+ i4 <- textBufferGetIterAtMark workBuffer mark+ columnNew <- textIterGetLineOffset i4+ return (line,columnNew)++positionToCandy :: CandyTable -> TextBuffer -> (Int,Int) -> IO (Int,Int)+positionToCandy candyTable gtkbuf (line,column) = do+ i1 <- textBufferGetIterAtLine gtkbuf (max 0 (line - 1))+ i2 <- textIterCopy i1+ textIterForwardToLineEnd i2+ text <- textBufferGetText gtkbuf i1 i2 True+ workBuffer <- textBufferNew Nothing+ textBufferSetText workBuffer text+ transformFromCandy candyTable workBuffer+ i3 <- textBufferGetIterAtOffset workBuffer column+ mark <- textBufferCreateMark workBuffer Nothing i3 True+ transformToCandy candyTable workBuffer+ i4 <- textBufferGetIterAtMark workBuffer mark+ columnNew <- textIterGetLineOffset i4+ return (line,columnNew) replaceFrom :: TextBuffer -> (String,String,Int) -> Int -> IO () replaceFrom buf (to,from,spaces) offset = replaceFrom' offset
+ src/IDE/Tool.hs view
@@ -0,0 +1,326 @@+{-# OPTIONS_GHC -XRecordWildCards #-}+-----------------------------------------------------------------------------+--+-- Module : IDE.Tool+-- Copyright : (c) Hamish Mackenzie, Juergen Nicklisch-Franken+-- License : GPL+--+-- Maintainer : <maintainer@leksah.org>+-- Stability : provisional+-- Portability :+--+-- | Support for running external tools. Written mainly for GHCi but with+-- | support for others in mind.+--+-----------------------------------------------------------------------------++module IDE.Tool (+ ToolOutput(..),+ toolline,+ ToolCommand(..),+ ToolState(..),+ newToolState,+ runTool,+ runInteractiveTool,+ newGhci,+ executeCommand,+ executeGhciCommand)+where++import System.IO+import Control.Concurrent+ (takeMVar,+ putMVar,+ newEmptyMVar,+ forkIO,+ newChan,+ MVar(..),+ Chan(..),+ writeChan,+ getChanContents,+ dupChan)+import Control.Monad (when)+import Data.List (stripPrefix)+import Data.Maybe (isJust, catMaybes)+#if !defined(mingw32_HOST_OS) && !defined(__MINGW32__)+import System.Posix (sigQUIT, sigINT, installHandler)+import System.Posix.Signals (Handler(..))+#endif+import System.Process+ (waitForProcess, ProcessHandle(..), runInteractiveProcess)++data ToolOutput = ToolInput String | ToolError String | ToolOutput String deriving(Eq, Show)+data ToolCommand = ToolCommand String ([ToolOutput] -> IO ())+data ToolState = ToolState {+ toolProcess :: MVar ProcessHandle,+ outputClosed :: MVar Bool,+ toolCommands :: Chan ToolCommand,+ toolCommandsRead :: Chan ToolCommand,+ currentToolCommand :: MVar ToolCommand}++data RawToolOutput = RawToolOutput ToolOutput+ | ToolPrompt+ | ToolOutClosed+ | ToolErrClosed+ | ToolClosed deriving(Eq, Show)++toolline :: ToolOutput -> String+toolline (ToolInput l) = l+toolline (ToolOutput l) = l+toolline (ToolError l) = l++runTool :: FilePath -> [String] -> IO ([ToolOutput], ProcessHandle)+runTool executable arguments = do+#if !defined(mingw32_HOST_OS) && !defined(__MINGW32__)+ installHandler sigINT Ignore Nothing+ installHandler sigQUIT Ignore Nothing+#endif++ (inp,out,err,pid) <- runInteractiveProcess executable arguments Nothing Nothing+ output <- getOutputNoPrompt inp out err pid+ return (output, pid)++newToolState :: IO ToolState+newToolState = do+ toolProcess <- newEmptyMVar+ outputClosed <- newEmptyMVar+ toolCommands <- newChan+ toolCommandsRead <- dupChan toolCommands+ currentToolCommand <- newEmptyMVar+ return ToolState{..}++runInteractiveTool :: ToolState -> (Handle -> Handle -> Handle -> ProcessHandle -> IO [RawToolOutput]) -> FilePath -> [String] -> IO ()+runInteractiveTool tool getOutput executable arguments = do+#if !defined(mingw32_HOST_OS) && !defined(__MINGW32__)+ installHandler sigINT Ignore Nothing+ installHandler sigQUIT Ignore Nothing+#endif++ (inp,out,err,pid) <- runInteractiveProcess executable arguments Nothing Nothing+ putMVar (toolProcess tool) pid+ output <- getOutput inp out err pid+ -- This is handy to show the processed output+ -- forkIO $ forM_ output (putStrLn.show)+ forkIO $ do+ commands <- getChanContents (toolCommandsRead tool)+ processCommand commands inp output+ return ()+ where+ processCommand [] _ _ = return ()+ processCommand ((command@(ToolCommand commandString handler)):remainingCommands) inp allOutput = do+ putMVar (currentToolCommand tool) command+ hPutStrLn inp commandString+ hFlush inp+ let (output, remainingOutputWithPrompt) = span (/= ToolPrompt) allOutput+ handler $ (map ToolInput (lines commandString)) ++ fromRawOutput output+ takeMVar (currentToolCommand tool)+ case remainingOutputWithPrompt of+ (ToolPrompt:remainingOutput) -> do+ processCommand remainingCommands inp remainingOutput+ [] -> do+ putMVar (outputClosed tool) True+ _ -> do+ putStrLn "This should never happen in Tool.hs"++newInteractiveTool :: (Handle -> Handle -> Handle -> ProcessHandle -> IO [RawToolOutput]) -> FilePath -> [String] -> IO ToolState+newInteractiveTool getOutput executable arguments = do+ tool <- newToolState+ runInteractiveTool tool getOutput executable arguments+ return tool++ghciPrompt :: String+ghciPrompt = "3KM2KWR7LZZbHdXfHUOA5YBBsJVYoCQnKX"++data CommanLineReader = CommanLineReader {+ stripInitialPrompt :: String -> Maybe String,+ stripFollowingPrompt :: String -> Maybe String,+ errorSyncCommand :: Maybe String,+ stripExpectedError :: String -> Maybe String+ }++ghciStripInitialPrompt :: String -> Maybe String+ghciStripInitialPrompt output =+ case catMaybes [stripPrefix "Prelude" output, stripPrefix "*" output] of+ remaining:_ ->+ case dropWhile (/= '>') remaining of+ '>':' ':next -> Just next+ _ -> Nothing+ _ -> Nothing++ghciStripFollowingPrompt :: String -> Maybe String+ghciStripFollowingPrompt = stripPrefix ghciPrompt++ghciStripExpectedError :: String -> Maybe String+ghciStripExpectedError output = case stripPrefix "\n<interactive>:1:0" output of+ Just rest ->+ stripPrefix ": Not in scope: `kM2KWR7LZZbHdXfHUOA5YBBsJVYoC'\n"+ (maybe rest id (stripPrefix "-28" rest))+ Nothing -> Nothing++ghciCommandLineReader = CommanLineReader {+ stripInitialPrompt = ghciStripInitialPrompt,+ stripFollowingPrompt = ghciStripFollowingPrompt,+ errorSyncCommand = Just "kM2KWR7LZZbHdXfHUOA5YBBsJVYoC",+ stripExpectedError = ghciStripExpectedError+ }++noInputCommandLineReader = CommanLineReader {+ stripInitialPrompt = const Nothing,+ stripFollowingPrompt = const Nothing,+ errorSyncCommand = Nothing,+ stripExpectedError = const Nothing+ }+--waitTillEmpty :: Handle -> IO ()+--waitTillEmpty handle = do+-- ready <- hReady handle+-- when ready $ do+-- yield+-- threadDelay 100+-- yield+-- waitTillEmpty handle++getOutput :: CommanLineReader -> Handle -> Handle -> Handle -> ProcessHandle -> IO [RawToolOutput]+getOutput clr inp out err pid = do+ chan <- newChan+ -- hSetBuffering out NoBuffering+ -- hSetBuffering err NoBuffering+ foundExpectedError <- newEmptyMVar+ -- Use this and the too putStr threads bellow if you want to see the raw output+ -- hSetBuffering stdout NoBuffering+ forkIO $ do+ errors <- hGetContents err+ -- forkIO $ putStr errors+ readError chan (filter (/= '\r') errors) foundExpectedError+ writeChan chan ToolErrClosed+ forkIO $ do+ output <- hGetContents out+ -- forkIO $ putStr output+ readOutput chan (filter (/= '\r') output) True foundExpectedError False+ writeChan chan ToolOutClosed+ forkIO $ do+ testClosed <- dupChan chan+ output <- getChanContents testClosed+ when ((ToolOutClosed `elem` output) && (ToolErrClosed `elem` output)) $ do+ waitForProcess pid+ writeChan chan ToolClosed+ fmap (takeWhile ((/=) ToolClosed)) $ getChanContents chan+ where+ readError chan errors foundExpectedError = do+ case stripExpectedError clr errors of+ Just unexpectedErrors -> do+ putMVar foundExpectedError True+ readError chan unexpectedErrors foundExpectedError+ Nothing -> do+ let (line, remaining) = break (== '\n') errors+ case remaining of+ [] -> return ()+ _:remainingLines -> do+ writeChan chan $ RawToolOutput $ ToolError line+ readError chan remainingLines foundExpectedError++ readOutput chan output initial foundExpectedError synced = do+ let stripPrompt = (if initial then (stripInitialPrompt clr) else (stripFollowingPrompt clr))+ let line = getLine stripPrompt output+ let remaining = drop (length line) output+ case remaining of+ [] -> do+ when (line /= "") $ writeChan chan $ RawToolOutput $ ToolOutput line+ '\n':remainingLines -> do+ writeChan chan $ RawToolOutput $ ToolOutput line+ readOutput chan remainingLines initial foundExpectedError synced+ _ -> do+ when (line /= "") $ writeChan chan $ RawToolOutput $ ToolOutput line+ case stripPrompt remaining of+ Just afterPrompt -> do+ case (initial, synced, errorSyncCommand clr) of+ (True, _, _) -> do+ readOutput chan afterPrompt False foundExpectedError synced+ (False, _, Nothing) -> do+ writeChan chan ToolPrompt+ readOutput chan afterPrompt False foundExpectedError synced+ (False, False, Just syncCmd) -> do+ hPutStrLn inp syncCmd+ hFlush inp+ takeMVar foundExpectedError+ readOutput chan afterPrompt False foundExpectedError True+ (False, True, Just _) -> do+ writeChan chan ToolPrompt+ readOutput chan afterPrompt False foundExpectedError False+ _ -> return () -- Should never happen+ getLine _ [] = []+ getLine _ ('\n':xs) = []+ getLine stripPrompt output@(x:xs)+ | isJust (stripPrompt output) = []+ | otherwise = x : (getLine stripPrompt xs)++fromRawOutput :: [RawToolOutput] -> [ToolOutput]+fromRawOutput [] = []+fromRawOutput (RawToolOutput output:xs) = output : (fromRawOutput xs)+fromRawOutput (ToolClosed:xs) = []+fromRawOutput (_:xs) = fromRawOutput xs++getGhciOutput :: Handle -> Handle -> Handle -> ProcessHandle -> IO [RawToolOutput]+getGhciOutput = getOutput ghciCommandLineReader++getOutputNoPrompt :: Handle -> Handle -> Handle -> ProcessHandle -> IO [ToolOutput]+getOutputNoPrompt inp out err pid = fmap fromRawOutput $ getOutput noInputCommandLineReader inp out err pid++newGhci :: [String] -> [String] -> ([ToolOutput] -> IO ()) -> IO ToolState+newGhci buildFlags interactiveFlags startupOutputHandler = do+ tool <- newToolState+ writeChan (toolCommands tool) $+ ToolCommand (":set prompt " ++ ghciPrompt) startupOutputHandler+ putStrLn "Working out GHCi options"+ forkIO $ do+ (output, pid) <- runTool "runhaskell" (["Setup","build","--with-ghc=leksahecho"] ++ buildFlags)+ case catMaybes $ map (findMake . toolline) output of+ options:_ -> do+ let newOptions = filterUnwanted options+ putStrLn newOptions+ putStrLn "Starting GHCi"+ runInteractiveTool tool getGhciOutput "ghci"+ (words newOptions ++ ["-fforce-recomp"] ++ interactiveFlags)+ _ -> do+ startupOutputHandler output+ putMVar (outputClosed tool) True+ return tool+ where+ findMake [] = Nothing+ findMake line@(x:xs) =+ case stripPrefix " --make " line of+ Nothing -> findMake xs+ s -> s+ filterUnwanted [] = []+ filterUnwanted line@(x:xs) =+ case stripPrefix "-O " line of+ Nothing -> x: filterUnwanted xs+ Just s -> filterUnwanted s+++executeCommand :: ToolState -> String -> ([ToolOutput] -> IO ()) -> IO ()+executeCommand tool command handler = do+ writeChan (toolCommands tool) $ ToolCommand command handler++executeGhciCommand :: ToolState -> String -> ([ToolOutput] -> IO ()) -> IO ()+executeGhciCommand tool command handler = do+ if '\n' `elem` command+ then executeCommand tool safeCommand $ \output -> do+ handler $ fixInput $ fixOutput output+ else executeCommand tool command handler+ where+ filteredLines = (filter safeLine (lines command))+ promptCount = (length filteredLines)+1+ safeCommand = (unlines ([":{"] ++ filteredLines)) ++ ":}"+ safeLine ":{" = False+ safeLine ":}" = False+ safeLine _ = True+ fixOutput ((ToolOutput line):xs) = (ToolOutput (removePrompts line line promptCount)):xs+ fixOutput (x:xs) = x:(fixOutput xs)+ fixOutput [] = []+ fixInput = filter (\x -> (x /= ToolInput ":{") && (x /= ToolInput ":}"))+ removePrompts fullLine line 0 = line+ removePrompts fullLine line n = case dropWhile ((/=) '|') line of+ '|':' ':xs -> removePrompts fullLine xs (n-1)+ _ -> fullLine++
+ src/LeksahEcho.hs view
@@ -0,0 +1,24 @@+-----------------------------------------------------------------------------+--+-- Module : Main+-- Copyright : 2007-2009 Jürgen Nicklisch-Franken, Hamish Mackenzie+-- License : GPL+--+-- Maintainer : maintainer@leksah.org+-- Stability : provisional+-- Portability :+--+-- | Windows systems do not often have a real echo executable (so --with-ghc=echo fails)+--+-----------------------------------------------------------------------------++module Main (+main+) where++import System.Environment++main = do+ args <- getArgs+ putStrLn $ unwords args+