diff --git a/Readme b/Readme --- a/Readme +++ b/Readme @@ -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. diff --git a/data/Current.session b/data/Current.session --- a/data/Current.session +++ b/data/Current.session @@ -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"] diff --git a/data/Default.candy b/data/Default.candy --- a/data/Default.candy +++ b/data/Default.candy @@ -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 diff --git a/data/Default.keymap b/data/Default.keymap --- a/data/Default.keymap +++ b/data/Default.keymap @@ -100,4 +100,10 @@ space -> StartComplete "Initiate complete in a source buffer" +F6 -> DebugStep +F7 -> DebugStepLocal +F8 -> DebugStepModule +F9 -> DebugContinue + + diff --git a/data/Default.menu b/data/Default.menu --- a/data/Default.menu +++ b/data/Default.menu @@ -39,9 +39,6 @@ - - - @@ -70,13 +67,30 @@ + + + + + + + + + + + + + + + + + - + @@ -89,6 +103,9 @@ + + + @@ -103,7 +120,13 @@ + + + + + + @@ -137,9 +160,37 @@ + + + + + + + + + + + + + + + + + + + + + + + + + + + + diff --git a/data/Default.prefs b/data/Default.prefs --- a/data/Default.prefs +++ b/data/Default.prefs @@ -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= diff --git a/data/ide_build.png b/data/ide_build.png Binary files a/data/ide_build.png and b/data/ide_build.png differ diff --git a/data/ide_class.png b/data/ide_class.png Binary files a/data/ide_class.png and b/data/ide_class.png differ diff --git a/data/ide_continue.png b/data/ide_continue.png new file mode 100644 Binary files /dev/null and b/data/ide_continue.png differ diff --git a/data/ide_data.png b/data/ide_data.png Binary files a/data/ide_data.png and b/data/ide_data.png differ diff --git a/data/ide_debug.png b/data/ide_debug.png new file mode 100644 Binary files /dev/null and b/data/ide_debug.png differ diff --git a/data/ide_field.png b/data/ide_field.png deleted file mode 100644 Binary files a/data/ide_field.png and /dev/null differ diff --git a/data/ide_function.png b/data/ide_function.png Binary files a/data/ide_function.png and b/data/ide_function.png differ diff --git a/data/ide_instance.png b/data/ide_instance.png Binary files a/data/ide_instance.png and b/data/ide_instance.png differ diff --git a/data/ide_konstructor.png b/data/ide_konstructor.png Binary files a/data/ide_konstructor.png and b/data/ide_konstructor.png differ diff --git a/data/ide_local.png b/data/ide_local.png new file mode 100644 Binary files /dev/null and b/data/ide_local.png differ diff --git a/data/ide_method.png b/data/ide_method.png Binary files a/data/ide_method.png and b/data/ide_method.png differ diff --git a/data/ide_module.png b/data/ide_module.png new file mode 100644 Binary files /dev/null and b/data/ide_module.png differ diff --git a/data/ide_newtype.png b/data/ide_newtype.png Binary files a/data/ide_newtype.png and b/data/ide_newtype.png differ diff --git a/data/ide_rebuild_meta.png b/data/ide_rebuild_meta.png new file mode 100644 Binary files /dev/null and b/data/ide_rebuild_meta.png differ diff --git a/data/ide_reexported.png b/data/ide_reexported.png Binary files a/data/ide_reexported.png and b/data/ide_reexported.png differ diff --git a/data/ide_rule.png b/data/ide_rule.png Binary files a/data/ide_rule.png and b/data/ide_rule.png differ diff --git a/data/ide_run.png b/data/ide_run.png Binary files a/data/ide_run.png and b/data/ide_run.png differ diff --git a/data/ide_slot.png b/data/ide_slot.png Binary files a/data/ide_slot.png and b/data/ide_slot.png differ diff --git a/data/ide_source.png b/data/ide_source.png Binary files a/data/ide_source.png and b/data/ide_source.png differ diff --git a/data/ide_step.png b/data/ide_step.png new file mode 100644 Binary files /dev/null and b/data/ide_step.png differ diff --git a/data/ide_type.png b/data/ide_type.png Binary files a/data/ide_type.png and b/data/ide_type.png differ diff --git a/data/leksah.png b/data/leksah.png Binary files a/data/leksah.png and b/data/leksah.png differ diff --git a/data/welcome.txt b/data/welcome.txt --- a/data/welcome.txt +++ b/data/welcome.txt @@ -1,4 +1,6 @@ + + # # ###### # #### #### # # ###### ##### #### # # # # # # # # ## ## # # # # # # ##### # # # # # ## # ##### # # # diff --git a/leksah.cabal b/leksah.cabal --- a/leksah.cabal +++ b/leksah.cabal @@ -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: diff --git a/src/DeepSeq.hs b/src/DeepSeq.hs --- a/src/DeepSeq.hs +++ b/src/DeepSeq.hs @@ -1,3 +1,17 @@ +----------------------------------------------------------------------------- +-- +-- Module : Default +-- Copyright : (c) Juergen Nicklisch-Franken, Hamish Mackenzie +-- License : GNU-GPL +-- +-- Maintainer : Juergen Nicklisch-Franken +-- Stability : provisional +-- Portability : portable +-- +-- | Module for default values of a data type +-- +------------------------------------------------------------------------------ + module DeepSeq where class DeepSeq a where diff --git a/src/Graphics/UI/Editor/Basics.hs b/src/Graphics/UI/Editor/Basics.hs --- a/src/Graphics/UI/Editor/Basics.hs +++ b/src/Graphics/UI/Editor/Basics.hs @@ -41,8 +41,6 @@ import Data.IORef import Control.Monad ---import Debug.Trace - import Graphics.UI.Editor.Parameters import Control.Event import MyMissing(allOf) diff --git a/src/Graphics/UI/Editor/Composite.hs b/src/Graphics/UI/Editor/Composite.hs --- a/src/Graphics/UI/Editor/Composite.hs +++ b/src/Graphics/UI/Editor/Composite.hs @@ -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 diff --git a/src/Graphics/UI/Editor/MakeEditor.hs b/src/Graphics/UI/Editor/MakeEditor.hs --- a/src/Graphics/UI/Editor/MakeEditor.hs +++ b/src/Graphics/UI/Editor/MakeEditor.hs @@ -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 diff --git a/src/Graphics/UI/Editor/Simple.hs b/src/Graphics/UI/Editor/Simple.hs --- a/src/Graphics/UI/Editor/Simple.hs +++ b/src/Graphics/UI/Editor/Simple.hs @@ -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) diff --git a/src/Graphics/UI/Frame/Panes.hs b/src/Graphics/UI/Frame/Panes.hs --- a/src/Graphics/UI/Frame/Panes.hs +++ b/src/Graphics/UI/Frame/Panes.hs @@ -1,7 +1,8 @@ {-# OPTIONS_GHC -XExistentialQuantification -XMultiParamTypeClasses - -XFunctionalDependencies #-} + -XFunctionalDependencies + -XNoMonomorphismRestriction #-} ----------------------------------------------------------------------------- -- -- Module : IDE.Core.Panes @@ -9,7 +10,7 @@ -- License : GNU-GPL -- -- Maintainer : --- 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 diff --git a/src/Graphics/UI/Frame/ViewFrame.hs b/src/Graphics/UI/Frame/ViewFrame.hs --- a/src/Graphics/UI/Frame/ViewFrame.hs +++ b/src/Graphics/UI/Frame/ViewFrame.hs @@ -1,653 +1,1360 @@ -{-# OPTIONS_GHC #-} ------------------------------------------------------------------------------ --- --- Module : IDE.Core.ViewFrame --- Copyright : (c) Juergen Nicklisch-Franken, Hamish Mackenzie --- License : GNU-GPL --- --- Maintainer : --- 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 : +-- 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 "" ++ text ++ "" + 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 ("" ++ group ++ "") + 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 diff --git a/src/IDE/Completion.hs b/src/IDE/Completion.hs --- a/src/IDE/Completion.hs +++ b/src/IDE/Completion.hs @@ -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 diff --git a/src/IDE/Core/State.hs b/src/IDE/Core/State.hs --- a/src/IDE/Core/State.hs +++ b/src/IDE/Core/State.hs @@ -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 - diff --git a/src/IDE/Core/Types.hs b/src/IDE/Core/Types.hs --- a/src/IDE/Core/Types.hs +++ b/src/IDE/Core/Types.hs @@ -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} + + diff --git a/src/IDE/Debug.hs b/src/IDE/Debug.hs new file mode 100644 --- /dev/null +++ b/src/IDE/Debug.hs @@ -0,0 +1,443 @@ +{-# LANGUAGE CPP, ForeignFunctionInterface #-} +{-# OPTIONS_GHC -XScopedTypeVariables #-} +----------------------------------------------------------------------------- +-- +-- Module : IDE.Debug +-- Copyright : (c) Hamish Mackenzie, Juergen Nicklisch-Franken +-- License : GNU-GPL +-- +-- Maintainer : +-- 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 + + diff --git a/src/IDE/FileUtils.hs b/src/IDE/FileUtils.hs --- a/src/IDE/FileUtils.hs +++ b/src/IDE/FileUtils.hs @@ -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" diff --git a/src/IDE/Find.hs b/src/IDE/Find.hs --- a/src/IDE/Find.hs +++ b/src/IDE/Find.hs @@ -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 diff --git a/src/IDE/GUIHistory.hs b/src/IDE/GUIHistory.hs --- a/src/IDE/GUIHistory.hs +++ b/src/IDE/GUIHistory.hs @@ -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 diff --git a/src/IDE/Group/Debugger.hs b/src/IDE/Group/Debugger.hs new file mode 100644 --- /dev/null +++ b/src/IDE/Group/Debugger.hs @@ -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 () diff --git a/src/IDE/ImportTool.hs b/src/IDE/ImportTool.hs --- a/src/IDE/ImportTool.hs +++ b/src/IDE/ImportTool.hs @@ -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 diff --git a/src/IDE/Leksah.hs b/src/IDE/Leksah.hs --- a/src/IDE/Leksah.hs +++ b/src/IDE/Leksah.hs @@ -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 [ diff --git a/src/IDE/LogRef.hs b/src/IDE/LogRef.hs new file mode 100644 --- /dev/null +++ b/src/IDE/LogRef.hs @@ -0,0 +1,522 @@ +{-# OPTIONS_GHC -XScopedTypeVariables #-} +----------------------------------------------------------------------------- +-- +-- Module : IDE.LogRef +-- Copyright : (c) Juergen Nicklisch-Franken, Hamish Mackenzie +-- License : GNU-GPL +-- +-- Maintainer : +-- 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] + _ -> [] + _ -> [] + diff --git a/src/IDE/Menu.hs b/src/IDE/Menu.hs --- a/src/IDE/Menu.hs +++ b/src/IDE/Menu.hs @@ -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 "X"--} False - ,AD "EditCopy" "_Copy" Nothing Nothing{--Just "gtk-copy"--} + ,AD "EditCopy" "_Copy" Nothing (Just "gtk-copy") editCopy [] {--Just "C"--} False - ,AD "EditPaste" "_Paste" Nothing Nothing{--Just "gtk-paste"--} + ,AD "EditPaste" "_Paste" Nothing (Just "gtk-paste") editPaste [] {--Just "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 "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 () diff --git a/src/IDE/Metainfo/GHCUtils.hs b/src/IDE/Metainfo/GHCUtils.hs --- a/src/IDE/Metainfo/GHCUtils.hs +++ b/src/IDE/Metainfo/GHCUtils.hs @@ -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) diff --git a/src/IDE/Metainfo/InterfaceCollector.hs b/src/IDE/Metainfo/InterfaceCollector.hs --- a/src/IDE/Metainfo/InterfaceCollector.hs +++ b/src/IDE/Metainfo/InterfaceCollector.hs @@ -344,7 +344,7 @@ in [descr{details' = ClassDescr{super = superclasses, methods = classOpsID}}] (IfaceSyn _ _ _ _ _ ) - -> [descr] + -> [descr{details' = TypeDescr}] (IfaceForeign _ _) -> [descr] diff --git a/src/IDE/Metainfo/Provider.hs b/src/IDE/Metainfo/Provider.hs --- a/src/IDE/Metainfo/Provider.hs +++ b/src/IDE/Metainfo/Provider.hs @@ -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 diff --git a/src/IDE/Metainfo/SourceCollector.hs b/src/IDE/Metainfo/SourceCollector.hs --- a/src/IDE/Metainfo/SourceCollector.hs +++ b/src/IDE/Metainfo/SourceCollector.hs @@ -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 diff --git a/src/IDE/NotebookFlipper.hs b/src/IDE/NotebookFlipper.hs --- a/src/IDE/NotebookFlipper.hs +++ b/src/IDE/NotebookFlipper.hs @@ -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 diff --git a/src/IDE/Package.hs b/src/IDE/Package.hs --- a/src/IDE/Package.hs +++ b/src/IDE/Package.hs @@ -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 + diff --git a/src/IDE/Pane/Breakpoints.hs b/src/IDE/Pane/Breakpoints.hs new file mode 100644 --- /dev/null +++ b/src/IDE/Pane/Breakpoints.hs @@ -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" + + + + + + diff --git a/src/IDE/Pane/ClassHierarchy.hs b/src/IDE/Pane/ClassHierarchy.hs --- a/src/IDE/Pane/ClassHierarchy.hs +++ b/src/IDE/Pane/ClassHierarchy.hs @@ -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]) {-- diff --git a/src/IDE/Pane/Errors.hs b/src/IDE/Pane/Errors.hs new file mode 100644 --- /dev/null +++ b/src/IDE/Pane/Errors.hs @@ -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" + + + + + + diff --git a/src/IDE/Pane/Grep.hs b/src/IDE/Pane/Grep.hs new file mode 100644 --- /dev/null +++ b/src/IDE/Pane/Grep.hs @@ -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 : +-- 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 + + diff --git a/src/IDE/Pane/Info.hs b/src/IDE/Pane/Info.hs --- a/src/IDE/Pane/Info.hs +++ b/src/IDE/Pane/Info.hs @@ -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 () diff --git a/src/IDE/Pane/Log.hs b/src/IDE/Pane/Log.hs --- a/src/IDE/Pane/Log.hs +++ b/src/IDE/Pane/Log.hs @@ -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 diff --git a/src/IDE/Pane/Modules.hs b/src/IDE/Pane/Modules.hs --- a/src/IDE/Pane/Modules.hs +++ b/src/IDE/Pane/Modules.hs @@ -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 () diff --git a/src/IDE/Pane/PackageEditor.hs b/src/IDE/Pane/PackageEditor.hs --- a/src/IDE/Pane/PackageEditor.hs +++ b/src/IDE/Pane/PackageEditor.hs @@ -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})}) diff --git a/src/IDE/Pane/PackageFlags.hs b/src/IDE/Pane/PackageFlags.hs --- a/src/IDE/Pane/PackageFlags.hs +++ b/src/IDE/Pane/PackageFlags.hs @@ -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,[]) diff --git a/src/IDE/Pane/Preferences.hs b/src/IDE/Pane/Preferences.hs --- a/src/IDE/Pane/Preferences.hs +++ b/src/IDE/Pane/Preferences.hs @@ -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 } -- ------------------------------------------------------------ diff --git a/src/IDE/Pane/References.hs b/src/IDE/Pane/References.hs --- a/src/IDE/Pane/References.hs +++ b/src/IDE/Pane/References.hs @@ -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 diff --git a/src/IDE/Pane/Search.hs b/src/IDE/Pane/Search.hs --- a/src/IDE/Pane/Search.hs +++ b/src/IDE/Pane/Search.hs @@ -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 diff --git a/src/IDE/Pane/SourceBuffer.hs b/src/IDE/Pane/SourceBuffer.hs --- a/src/IDE/Pane/SourceBuffer.hs +++ b/src/IDE/Pane/SourceBuffer.hs @@ -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 "" ++ text ++ "" - 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 diff --git a/src/IDE/Pane/Trace.hs b/src/IDE/Pane/Trace.hs new file mode 100644 --- /dev/null +++ b/src/IDE/Pane/Trace.hs @@ -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 "" + 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 + + + diff --git a/src/IDE/Pane/Variables.hs b/src/IDE/Pane/Variables.hs new file mode 100644 --- /dev/null +++ b/src/IDE/Pane/Variables.hs @@ -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})) + diff --git a/src/IDE/SaveSession.hs b/src/IDE/SaveSession.hs --- a/src/IDE/SaveSession.hs +++ b/src/IDE/SaveSession.hs @@ -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 diff --git a/src/IDE/SourceCandy.hs b/src/IDE/SourceCandy.hs --- a/src/IDE/SourceCandy.hs +++ b/src/IDE/SourceCandy.hs @@ -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 diff --git a/src/IDE/Tool.hs b/src/IDE/Tool.hs new file mode 100644 --- /dev/null +++ b/src/IDE/Tool.hs @@ -0,0 +1,326 @@ +{-# OPTIONS_GHC -XRecordWildCards #-} +----------------------------------------------------------------------------- +-- +-- Module : IDE.Tool +-- Copyright : (c) Hamish Mackenzie, Juergen Nicklisch-Franken +-- License : GPL +-- +-- Maintainer : +-- 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: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 + + diff --git a/src/LeksahEcho.hs b/src/LeksahEcho.hs new file mode 100644 --- /dev/null +++ b/src/LeksahEcho.hs @@ -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 +