leksah 0.8.0.8 → 0.10.0.0
raw patch · 41 files changed
+3079/−2123 lines, 41 filesdep +dyredep +ghcdep +ige-mac-integrationdep ~Cabaldep ~basedep ~binary-shared
Dependencies added: dyre, ghc, ige-mac-integration, leksah, strict
Dependency ranges changed: Cabal, base, binary-shared, containers, filepath, glib, gtk, gtksourceview2, hslogger, leksah-server, ltk, mtl, time, yi
Files
- data/candy.lkshc +4/−4
- data/emacs.lkshk +1/−1
- data/keymap.lkshk +18/−13
- data/leksah.menu +4/−5
- data/prefs.lkshp +14/−14
- data/prefscoll.lkshp +6/−6
- leksah.cabal +91/−31
- main/Main.hs +26/−0
- src/IDE/BufferMode.hs +288/−0
- src/IDE/Build.hs +225/−0
- src/IDE/Command.hs +76/−65
- src/IDE/Completion.hs +196/−125
- src/IDE/Core/State.hs +2/−13
- src/IDE/Core/Types.hs +63/−16
- src/IDE/Debug.hs +115/−85
- src/IDE/Find.hs +10/−9
- src/IDE/ImportTool.hs +77/−31
- src/IDE/Keymap.hs +1/−1
- src/IDE/Leksah.hs +160/−91
- src/IDE/LogRef.hs +30/−22
- src/IDE/Metainfo/Provider.hs +6/−5
- src/IDE/OSX.hs +51/−37
- src/IDE/Package.hs +297/−233
- src/IDE/Pane/Errors.hs +21/−11
- src/IDE/Pane/Info.hs +47/−43
- src/IDE/Pane/Log.hs +16/−6
- src/IDE/Pane/Modules.hs +140/−60
- src/IDE/Pane/PackageEditor.hs +167/−148
- src/IDE/Pane/PackageFlags.hs +28/−16
- src/IDE/Pane/Preferences.hs +151/−72
- src/IDE/Pane/References.hs +0/−314
- src/IDE/Pane/SourceBuffer.hs +159/−236
- src/IDE/Pane/Trace.hs +6/−5
- src/IDE/Pane/Variables.hs +7/−5
- src/IDE/Pane/Workspace.hs +8/−14
- src/IDE/PaneGroups.hs +14/−5
- src/IDE/Session.hs +12/−4
- src/IDE/SourceCandy.hs +58/−35
- src/IDE/TextEditor.hs +184/−122
- src/IDE/Workspaces.hs +265/−213
- src/IDE/YiConfig.hs +35/−7
data/candy.lkshc view
@@ -1,6 +1,6 @@ -- Candy file -"->" 0x2192 Trimming --RIGHTWARDS ARROW -> -+"->" 0x2192 --RIGHTWARDS ARROW -> - "<-" 0x2190 Trimming --LEFTWARDS ARROW <- - "=>" 0x21d2 --RIGHTWARDS DOUBLE ARROW => - ">=" 0x2265 --GREATER-THAN OR EQUAL TO >= -@@ -9,11 +9,11 @@ "&&" 0x2227 --LOGICAL AND && - "||" 0x2228 --LOGICAL OR || - "++" 0x2295 --CIRCLED PLUS ++ ---- "::" 0x2237 Trimming --PROPORTION :: ---- ".." 0x2025 --TWO DOT LEADER .. -+"::" 0x2237 Trimming --PROPORTION :: -+".." 0x2025 --TWO DOT LEADER .. - "^" 0x2191 --UPWARDS ARROW ^ - "==" 0x2261 --IDENTICAL TO == --" . " 0x2218 --RING OPERATOR . -+-- " . " 0x2218 --RING OPERATOR . - "\" 0x03bb --GREEK SMALL LETTER LAMBDA \ - -- "=<<" 0x291e -- =<< - ">>=" 0x21a0 -- >>= -
data/emacs.lkshk view
@@ -5,7 +5,7 @@ --File-<ctrl>n -> FileNew "Opens a new empty buffer"+<ctrl>n -> FileNew "Creates a new haskell module" <ctrl>x/<ctrl>f -> FileOpen "Opens an existing file" <ctrl>x/<ctrl>s -> FileSave "Saves the current buffer" <ctrl>x/<ctrl>w -> FileSaveAs "Saves the current buffer as a new file"
data/keymap.lkshk view
@@ -1,14 +1,19 @@ --Default Keymap file for Leksah---Allowed Modifiers are <shift> <ctrl> <alt> <apple> <compose>---<apple> is the Windows key on PC keyboards+--Allowed Modifiers are <shift> <alt> <ctrl> <control> <compose>+--+--There are two versions of control so we can map them differently on OS X+--<ctrl> is the Apple key on OS X+--<control> is the Control key on OS X+-- --<compose> is often labelled Alt Gr.+-- --The defined values for the keys can can be found at -- http://gitweb.freedesktop.org/?p=xorg/proto/x11proto.git;a=blob_plain;f=keysymdef.h. -- The names of the keys are the names of the macros without the prefix. --File-<ctrl>n -> FileNew "Opens a new empty buffer"+<ctrl>n -> FileNew "Creates a new haskell module" <ctrl>o -> FileOpen "Opens an existing file" --<ctrl>x/<ctrl>f -> FileOpen "Opens an existing file" @@ -22,7 +27,7 @@ <ctrl>w -> FileClose "Closes the current buffer" --<ctrl>x/k -> FileClose "Closes the current buffer" -<alt>F4 -> Quit "Quits this program"+<ctrl>q -> Quit "Quits this program" --<ctrl>x/<ctrl>c -> Quit "Quits this program" --Edit@@ -38,15 +43,15 @@ -> EditDelete <ctrl>a -> EditSelectAll "Select the whole text in the current buffer" -<ctrl>f -> EditFind "Search for a text string (Toggles the "+<ctrl>f -> EditFind "Search for a text string" F3 -> EditFindNext "Find the next occurence of the text string" <shift>F3 -> EditFindPrevious "Find the previous occurence of the text string" <ctrl>l -> EditGotoLine "Go to line with a known index" -<ctrl><alt>Right -> EditComment "Add a line style comment to the selected lies"-<ctrl><alt>Left -> EditUncomment "Remove a line style comment"+<ctrl>d -> EditComment "Add a line style comment to the selected lies"+<ctrl><shift>d -> EditUncomment "Remove a line style comment" <alt>Right -> EditShiftRight "Shift right" <alt>Left -> EditShiftLeft "Shift Left" @@ -72,7 +77,7 @@ -> HelpAbout <ctrl>b -> BuildPackage-<ctrl>r -> AddAllImports+<ctrl>r -> ResolveErrors <ctrl><alt>r -> RunPackage @@ -95,18 +100,18 @@ <alt><shift>i -> AddAllImports -- "For the next to entries the <ctrl> modifier is mandatory"-<ctrl>Page_Up -> FlipUp "Switch to next pane in reverse recently used oder"-<ctrl>Page_Down -> FlipDown "Switch to next pane in recently used oder"+<control>Page_Up -> FlipUp "Switch to next pane in reverse recently used oder"+<control>Page_Down -> FlipDown "Switch to next pane in recently used oder" -<ctrl>space -> StartComplete "Initiate complete in a source buffer"+<control>space -> StartComplete "Initiate complete in a source buffer" F6 -> DebugStep F7 -> DebugStepLocal F8 -> DebugStepModule F9 -> DebugContinue -<ctrl>Return -> ExecuteSelection+<control>Return -> ExecuteSelection <ctrl>m -> UpdateMetadataCurrent -+<ctrl>p -> OpenDocu
@@ -1,7 +1,8 @@ <ui> <menubar> <menu name="_File" action="File">- <menuitem name="_New" action="FileNew" />+ <menuitem name="_New Module" action="FileNew" />+ <menuitem name="New _Text File" action="FileNewTextFile" /> <menuitem name="_Open" action="FileOpen" /> <menuitem name="_Recent Files" action="RecentFiles"/> <menuitem name="_Save" action="FileSave" />@@ -52,7 +53,7 @@ <separator/> <menuitem name="_Next Error" action="NextError" /> <menuitem name="_Previous Error" action="PreviousError" />- <menuitem name="_Add All Imports" action="AddAllImports" />+ <menuitem name="Resol_ve Errors" action="ResolveErrors" /> </menu> <menu name="_Package" action="Package"> <menuitem name="_New Package" action="NewPackage" />@@ -67,7 +68,6 @@ <menuitem name="C_opy Package" action="CopyPackage" /> <menuitem name="_Install Package" action="InstallPackage" /> <menuitem name="Re_gister Package" action="RegisterPackage" />- <menuitem name="_Unregister Package" action="UnregisterPackage" /> <menuitem name="Test Package" action="TestPackage" /> <menuitem name="SDist Package" action="SdistPackage" /> <menuitem name="_Build Documentation" action="DocPackage" />@@ -95,9 +95,7 @@ <menuitem name="_Errors" action="ShowErrors" /> <menuitem name="_Grep" action="ShowGrep" /> <menuitem name="_Log" action="ShowLog" />- <menuitem name="_References" action="ShowReferences" /> <menuitem name="_Search" action="ShowSearch" />- <menuitem name="_Workspace" action="ShowWorkspace" /> </menu> <menu name="_View" action="View"> <menuitem name="Split H_orizontal" action="ViewSplitHorizontal" />@@ -204,4 +202,5 @@ <accelerator name="Information" action="DebugInformation" /> <accelerator name="Kind" action="DebugKind" /> <accelerator name="Type" action="DebugType" />+ <accelerator name="OpenDocu" action="OpenDocu" /> </ui>
data/prefs.lkshp view
@@ -1,5 +1,5 @@ Version number of preferences file format:- 1+ 2 --Integer Time of last storage: "Fri Feb 26 16:43:57 CET 2010"@@ -7,15 +7,15 @@ True --(True/False) TextView Font: "Monospace 10"-Right margin: 100- --Size or 0 for no right margin+Right margin: (True,100)+ --Pair with True or False for use and number for column Tab width: 4 Use standard line ends even on windows: True Remove trailing blanks when saving a file: True-Source candy: "candy"- --Empty for do not use or the name of a candy file in a config dir+Source candy: (False,"candy")+ --Pair with True or False for use and name of a candy file in a config dir Editor Style: "" Found Text Background: Color 65535 65535 32768@@ -44,19 +44,19 @@ [SplitP LeftP] Paths under which haskell sources for packages may be found: []-Maybe a directory for unpacking cabal packages:- Just "~/.leksah-0.8/packageSources"-An URL to load prebuild metadata:+Unpack source for cabal packages to:+ Just "~/.leksah-0.10/packageSources"+URL from which to download prebuilt metadata: "http://www.leksah.org"-A strategy for downloading prebuild metadata:+Strategy for downloading prebuilt metadata: RetrieveThenBuild Update metadata at startup: True-Port number for server connection:+Port number for leksah to comunicate with leksah-server: 11111-Server IP address :+IP address for leksah to comunicate with leksah-server: "127.0.0.1"-End the server with last connection:+Stop the leksah-server process when leksah disconnects: True Packages which are excluded from the modules pane: [Dependency (PackageName "ghc") AnyVersion]@@ -78,5 +78,5 @@ False Browser: "firefox" URL for searching documentation:- "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=+ "http://www.holumbus.org/hayoo/hayoo.html?query="+ --e.g Hoogle: http://www.haskell.org/hoogle/?q= or Hayoo: http://www.holumbus.org/hayoo/hayoo.html?query=
data/prefscoll.lkshp view
@@ -1,12 +1,12 @@ Paths under which haskell sources for packages may be found: []-Maybe a directory for unpacking cabal packages:- Just "~/.leksah-0.8/packageSources"-An URL to load prebuild metadata:+Unpack source for cabal packages to:+ Just "~/.leksah-0.10/packageSources"+URL from which to download prebuilt metadata: "http://www.leksah.org"-A strategy for downloading prebuild metadata:+Strategy for downloading prebuilt metadata: RetrieveThenBuild-Port number for server connection:+Port number for leksah to comunicate with leksah-server: 11111-End the server with last connection:+Stop the leksah-server process when leksah disconnects: True
leksah.cabal view
@@ -1,6 +1,6 @@ name: leksah-version: 0.8.0.8-cabal-version: >=1.6+version: 0.10.0.0+cabal-version: >=1.8 build-type: Simple license: GPL license-file: LICENSE@@ -67,51 +67,111 @@ Default: False Description: Experimental Yi support -Executable leksah+flag dyre+ Default: True+ Description: Experimental Yi support++library if os(windows) build-depends: Win32 >=2.2.0.0 && <2.3 extra-libraries: kernel32+-- extra-lib-dirs: C:/cygwin/lib/w32api+ includes: windows.h+-- include-dirs: C:/cygwin/usr/include/w32api else build-depends: unix >=2.3.1.0 && <2.5 if os(osx)- extra-libraries: igemacintegration+ build-depends: ige-mac-integration >= 0.0.0.2 && <0.2 if flag(yi)- build-depends: yi >=0.6.1- cpp-options: -DYI- other-modules: IDE.YiConfig+ build-depends: yi >=0.6.1 && <0.7+ cpp-options: -DLEKSAH_WITH_YI - build-depends: Cabal >=1.6.0.1 && <1.9, base >=4.0.0.0 && <4.3, binary >=0.5.0.0 && <0.6,- bytestring >=0.9.0.1 && <0.10, containers >=0.2.0.0 && <0.4, directory >=1.0.0.2 && <3.1,- filepath >=1.1.0.1 && <1.2, glib >=0.10 && <0.12, gtk >=0.10 && <0.12,- gtksourceview2 >=0.10.0 && <0.12, mtl >=1.1.0.2 && <1.2, old-time >=1.0.0.1 && <1.1,+ if flag(yi) && flag(dyre)+ build-depends: dyre >= 0.8.3 && <0.9+ cpp-options: -DLEKSAH_WITH_YI_DYRE++ hs-source-dirs: src+ extensions: CPP++ build-depends: Cabal >=1.6.0.1 && <1.11, base >=4.0.0.0 && <4.4, binary >=0.5.0.0 && <0.6,+ bytestring >=0.9.0.1 && <0.10, containers >=0.2.0.0 && <0.5, directory >=1.0.0.2 && <3.1,+ filepath >=1.1.0.1 && <1.3, glib >=0.10 && <0.13, gtk >=0.10 && <0.13,+ gtksourceview2 >=0.10.0 && <0.13, mtl >=1.1.0.2 && <2.1, old-time >=1.0.0.1 && <1.1, parsec >=2.1.0.1 && <2.2, pretty >=1.0.1.0 && <1.1, process-leksah >=1.0.1.3 && <1.1, regex-tdfa ==1.1.*, regex-base ==0.93.*, utf8-string >=0.3.1.1 && <0.4, array >=0.2.0.0 && <0.4,- time >=0.1 && <1.2, ltk >=0.8.0.8 && <0.9, binary-shared >=0.8 && <=0.9, deepseq >=1.1.0.0 && <1.2,- hslogger >= 1.0.7 && <1.1, leksah-server >= 0.8.0.8 && <0.9, network >= 2.2 && <3.0- main-is: IDE/Leksah.hs- buildable: True- extensions: CPP- hs-source-dirs: src+ time >=0.1 && <1.3, ltk >= 0.10 && <0.11, binary-shared >= 0.8 && <0.9, deepseq >= 1.1.0.0 && <1.2,+ hslogger >= 1.0.7 && <1.2, leksah-server >= 0.10 && <0.11, network >= 2.2 && <3.0,+ ghc >=6.10.1 && <7.1, strict >= 0.3.2 && <0.4++ exposed-modules:+ IDE.Leksah IDE.Completion IDE.ImportTool+ IDE.Find IDE.Session IDE.Command IDE.Keymap IDE.Utils.GUIUtils+ IDE.Package IDE.YiConfig IDE.OSX+ IDE.GUIHistory IDE.SourceCandy IDE.NotebookFlipper+ IDE.Core.Types IDE.Core.State+ IDE.Metainfo.Provider+ IDE.Pane.Preferences IDE.Pane.PackageEditor+ IDE.Pane.Info IDE.Pane.Log IDE.Pane.SourceBuffer IDE.Pane.Modules+ IDE.Pane.Search IDE.Pane.PackageFlags+ IDE.LogRef IDE.Debug IDE.Pane.Grep+ IDE.Pane.Breakpoints IDE.Pane.Trace IDE.Pane.Variables+ IDE.Pane.Errors IDE.TextEditor IDE.Workspaces+ IDE.Statusbar IDE.Pane.Workspace IDE.PaneGroups+ IDE.Utils.ServerConnection+ IDE.BufferMode+ IDE.Build++ other-modules: Paths_leksah++ 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++Executable leksah if os(windows)+ build-depends: Win32 >=2.2.0.0 && <2.3+ extra-libraries: kernel32 -- extra-lib-dirs: C:/cygwin/lib/w32api includes: windows.h -- include-dirs: C:/cygwin/usr/include/w32api- other-modules: IDE.Completion IDE.ImportTool- IDE.Find IDE.Session IDE.Command IDE.Keymap IDE.Utils.GUIUtils- IDE.Package- IDE.GUIHistory IDE.SourceCandy IDE.NotebookFlipper- IDE.Core.Types IDE.Core.State- IDE.Metainfo.Provider- IDE.Pane.Preferences 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.LogRef IDE.Debug IDE.Pane.Grep- IDE.Pane.Breakpoints IDE.Pane.Trace IDE.Pane.Variables- IDE.Pane.Errors IDE.TextEditor IDE.Workspaces- IDE.Statusbar IDE.Pane.Workspace IDE.PaneGroups- IDE.Utils.ServerConnection IDE.OSX+ else+ build-depends: unix >=2.3.1.0 && <2.5++ if os(osx)+ build-depends: ige-mac-integration >= 0.0.0.2 && <0.2++ if flag(yi)+ cpp-options: -DLEKSAH_WITH_YI++ if flag(yi) && flag(dyre)+ cpp-options: -DLEKSAH_WITH_DYRE++ if impl(ghc < 6.12.3) && flag(yi)+ build-depends: yi >=0.6.1 && <0.7++ if impl(ghc < 6.12.3) && flag(yi) && flag(dyre)+ build-depends: dyre >= 0.8.3 && <0.9++ if impl(ghc < 6.12.3)+ hs-source-dirs: src, main+ build-depends: Cabal >=1.6.0.1 && <1.11, base >=4.0.0.0 && <4.4, binary >=0.5.0.0 && <0.6,+ bytestring >=0.9.0.1 && <0.10, containers >=0.2.0.0 && <0.5, directory >=1.0.0.2 && <3.1,+ filepath >=1.1.0.1 && <1.3, glib >=0.10 && <0.13, gtk >=0.10 && <0.13,+ gtksourceview2 >=0.10.0 && <0.13, mtl >=1.1.0.2 && <2.1, old-time >=1.0.0.1 && <1.1,+ parsec >=2.1.0.1 && <2.2, pretty >=1.0.1.0 && <1.1, process-leksah >=1.0.1.3 && <1.1,+ regex-tdfa ==1.1.*, regex-base ==0.93.*, utf8-string >=0.3.1.1 && <0.4, array >=0.2.0.0 && <0.4,+ time >=0.1 && <1.3, ltk >= 0.10 && <0.11, binary-shared >= 0.8 && <0.9, deepseq >= 1.1.0.0 && <1.2,+ hslogger >= 1.0.7 && <1.2, leksah-server >= 0.10 && <0.11, network >= 2.2 && <3.0,+ ghc >=6.10.1 && <7.1, strict >= 0.3.2 && <0.4+ else+ hs-source-dirs: main+ build-depends: leksah ==0.10.0.0, base >=4.0.0.0 && <= 5++ main-is: Main.hs+ buildable: True+ extensions: CPP 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
+ main/Main.hs view
@@ -0,0 +1,26 @@+{-# LANGUAGE CPP #-}+-----------------------------------------------------------------------------+--+-- Module : Main+-- Copyright : (c) Juergen Nicklisch-Franken, Hamish Mackenzie+-- License : GNU-GPL+--+-- Maintainer : <maintainer at leksah.org>+-- Stability : provisional+-- Portability : portable+--+--+-- Main function of Leksah, an Haskell IDE written in Haskell+--+---------------------------------------------------------------------------------++module Main (main) where++import IDE.Leksah (leksah)+import IDE.YiConfig (defaultYiConfig)++main :: IO ()+main = do+ putStrLn "Using default Yi configuration"+ leksah defaultYiConfig+
+ src/IDE/BufferMode.hs view
@@ -0,0 +1,288 @@+{-# OPTIONS_GHC -XDeriveDataTypeable -XTypeSynonymInstances -XMultiParamTypeClasses #-}+-----------------------------------------------------------------------------+--+-- Module : IDE.BufferMode+-- Copyright : 2007-2010 Juergen Nicklisch-Franken, Hamish Mackenzie+-- License : GPL Nothing+--+-- Maintainer : maintainer@leksah.org+-- Stability : provisional+-- Portability :+--+-- |+--+-----------------------------------------------------------------------------++module IDE.BufferMode where++import Prelude hiding(getLine)+import IDE.Core.State+import Data.List (isSuffixOf)+import IDE.TextEditor+ (getOffset, startsLine, getIterAtMark, getSelectionBoundMark,+ getInsertMark, EditorBuffer, getBuffer, EditorView, delete,+ getText, forwardCharsC, insert, getIterAtLine, getLine)+import Data.IORef (IORef)+import System.Time (ClockTime)+import Data.Typeable (cast, Typeable)+import IDE.SourceCandy+ (getCandylessText, keystrokeCandy, transformFromCandy,+ transformToCandy)+import IDE.Utils.GUIUtils (getCandyState)+import Control.Monad (when)+import Data.Maybe (catMaybes)+import IDE.Utils.FileUtils+import Control.Monad.Reader+import Graphics.UI.Gtk+ (castToWidget, notebookPageNum, Notebook, ScrolledWindow)+++-- * Buffer Basics++--+-- | A text editor pane description+--+data IDEBuffer = IDEBuffer {+ fileName :: Maybe FilePath+, bufferName :: String+, addedIndex :: Int+, sourceView :: EditorView+, scrolledWindow :: ScrolledWindow+, modTime :: IORef (Maybe (ClockTime))+, mode :: Mode+} deriving (Typeable)++instance Pane IDEBuffer IDEM+ where+ primPaneName = bufferName+ getAddedIndex = addedIndex+ getTopWidget = castToWidget . scrolledWindow+ paneId b = ""++data BufferState = BufferState FilePath Int+ | BufferStateTrans String String Int+ deriving(Eq,Ord,Read,Show,Typeable)++maybeActiveBuf :: IDEM (Maybe IDEBuffer)+maybeActiveBuf = do+ mbActivePane <- getActivePane+ mbPane <- lastActiveBufferPane+ case (mbPane,mbActivePane) of+ (Just paneName1, Just (paneName2,_)) | paneName1 == paneName2 -> do+ (PaneC pane) <- paneFromName paneName1+ let mbActbuf = cast pane+ return mbActbuf+ _ -> return Nothing++lastActiveBufferPane :: IDEM (Maybe PaneName)+lastActiveBufferPane = do+ rs <- recentSourceBuffers+ case rs of+ (hd : _) -> return (Just hd)+ _ -> return Nothing++recentSourceBuffers :: IDEM [PaneName]+recentSourceBuffers = do+ recentPanes' <- readIDE recentPanes+ mbBufs <- mapM mbPaneFromName recentPanes'+ return $ map paneName ((catMaybes $ map (\ (PaneC p) -> cast p) $ catMaybes mbBufs) :: [IDEBuffer])++getStartAndEndLineOfSelection :: EditorBuffer -> IDEM (Int,Int)+getStartAndEndLineOfSelection ebuf = do+ startMark <- getInsertMark ebuf+ endMark <- getSelectionBoundMark ebuf+ startIter <- getIterAtMark ebuf startMark+ endIter <- getIterAtMark ebuf endMark+ startLine <- getLine startIter+ endLine <- getLine endIter+ let (startLine',endLine',endIter') = if endLine >= startLine+ then (startLine,endLine,endIter)+ else (endLine,startLine,startIter)+ b <- startsLine endIter'+ let endLineReal = if b && endLine /= startLine then endLine' - 1 else endLine'+ return (startLine',endLineReal)++inBufContext :: alpha -> IDEBuffer -> (Notebook -> EditorBuffer -> IDEBuffer -> Int -> IDEM alpha) -> IDEM alpha+inBufContext def ideBuf f = do+ (pane,_) <- guiPropertiesFromName (paneName ideBuf)+ nb <- getNotebook pane+ mbI <- liftIO $notebookPageNum nb (scrolledWindow ideBuf)+ case mbI of+ Nothing -> liftIO $ do+ sysMessage Normal $ bufferName ideBuf ++ " notebook page not found: unexpected"+ return def+ Just i -> do+ ebuf <- getBuffer (sourceView ideBuf)+ f nb ebuf ideBuf i++inActiveBufContext :: alpha -> (Notebook -> EditorBuffer -> IDEBuffer -> Int -> IDEM alpha) -> IDEM alpha+inActiveBufContext def f = do+ mbBuf <- maybeActiveBuf+ case mbBuf of+ Nothing -> return def+ Just ideBuf -> do+ inBufContext def ideBuf f+++doForSelectedLines :: [a] -> (EditorBuffer -> Int -> IDEM a) -> IDEM [a]+doForSelectedLines d f = inActiveBufContext d $ \_ ebuf currentBuffer _ -> do+ (start,end) <- getStartAndEndLineOfSelection ebuf+ mapM (f ebuf) [start .. end]++-- * Buffer Modes++data Mode = Mode {+ modeName :: String,+ modeEditComment :: IDEAction,+ modeEditUncomment :: IDEAction,+ modeSelectedModuleName :: IDEM (Maybe String),+ modeEditToCandy :: IDEAction,+ modeEditFromCandy :: IDEAction,+ modeEditKeystrokeCandy :: Maybe Char -> IDEAction+ }+++-- | Assumes+modFromFileName :: Maybe FilePath -> Mode+modFromFileName Nothing = haskellMode+modFromFileName (Just fn) | isSuffixOf ".hs" fn = haskellMode+ | isSuffixOf ".lhs" fn = literalHaskellMode+ | isSuffixOf ".cabal" fn = cabalMode+ | otherwise = otherMode++haskellMode = Mode {+ modeName = "Haskell",+ modeEditComment = do+ doForSelectedLines [] $ \ebuf lineNr -> do+ sol <- getIterAtLine ebuf lineNr+ insert ebuf sol "--"+ return (),+ modeEditUncomment = do+ doForSelectedLines [] $ \ebuf lineNr -> do+ sol <- getIterAtLine ebuf lineNr+ sol2 <- forwardCharsC sol 2+ str <- getText ebuf sol sol2 True+ if str == "--"+ then do delete ebuf sol sol2+ else return ()+ return (),+ modeSelectedModuleName = do+ inActiveBufContext Nothing $ \_ ebuf currentBuffer _ -> do+ case fileName currentBuffer of+ Just filePath -> liftIO $ moduleNameFromFilePath filePath+ Nothing -> return Nothing,+ modeEditToCandy = do+ ct <- readIDE candy+ inActiveBufContext () $ \_ ebuf _ _ -> do+ transformToCandy ct ebuf,+ modeEditFromCandy = do+ ct <- readIDE candy+ inActiveBufContext () $ \_ ebuf _ _ -> do+ transformFromCandy ct ebuf,+ modeEditKeystrokeCandy = \c -> do+ ct <- readIDE candy+ inActiveBufContext () $ \_ ebuf _ _ -> do+ keystrokeCandy ct c ebuf+}++literalHaskellMode = Mode {+ modeName = "Literal Haskell",+ modeEditComment = do+ doForSelectedLines [] $ \ebuf lineNr -> do+ sol <- getIterAtLine ebuf lineNr+ sol2 <- forwardCharsC sol 1+ str <- getText ebuf sol sol2 True+ when (str == ">")+ (delete ebuf sol sol2)+ return (),+ modeEditUncomment = do+ doForSelectedLines [] $ \ebuf lineNr -> do+ sol <- getIterAtLine ebuf lineNr+ sol <- getIterAtLine ebuf lineNr+ sol2 <- forwardCharsC sol 1+ str <- getText ebuf sol sol2 True+ when (str /= ">")+ (insert ebuf sol ">")+ return (),+ modeSelectedModuleName = do+ inActiveBufContext Nothing $ \_ ebuf currentBuffer _ -> do+ case fileName currentBuffer of+ Just filePath -> liftIO $ moduleNameFromFilePath filePath+ Nothing -> return Nothing,+ modeEditToCandy = do+ ct <- readIDE candy+ inActiveBufContext () $ \_ ebuf _ _ -> do+ transformToCandy ct ebuf,+ modeEditFromCandy = do+ ct <- readIDE candy+ inActiveBufContext () $ \_ ebuf _ _ -> do+ transformFromCandy ct ebuf,+ modeEditKeystrokeCandy = \c -> do+ ct <- readIDE candy+ inActiveBufContext () $ \_ ebuf _ _ -> do+ keystrokeCandy ct c ebuf+}++cabalMode = Mode {+ modeName = "Cabal",+ modeEditComment = do+ doForSelectedLines [] $ \ebuf lineNr -> do+ sol <- getIterAtLine ebuf lineNr+ insert ebuf sol "--"+ return (),+ modeEditUncomment = do+ doForSelectedLines [] $ \ebuf lineNr -> do+ sol <- getIterAtLine ebuf lineNr+ sol2 <- forwardCharsC sol 2+ str <- getText ebuf sol sol2 True+ if str == "--"+ then do delete ebuf sol sol2+ else return ()+ return (),+ modeSelectedModuleName = return Nothing,+ modeEditToCandy = return (),+ modeEditFromCandy = return (),+ modeEditKeystrokeCandy = \c -> return ()+ }++otherMode = Mode {+ modeName = "Unknown",+ modeEditComment = return (),+ modeEditUncomment = return (),+ modeSelectedModuleName = return Nothing,+ modeEditToCandy = return (),+ modeEditFromCandy = return (),+ modeEditKeystrokeCandy = \c -> return ()+ }++isHaskellMode mode = modeName mode == "Haskell" || modeName mode == "Literal Haskell"++withCurrentMode :: alpha -> (Mode -> IDEM alpha) -> IDEM alpha+withCurrentMode def act = do+ mbBuf <- maybeActiveBuf+ case mbBuf of+ Nothing -> return def+ Just ideBuf -> act (mode ideBuf)++editComment :: IDEAction+editComment = withCurrentMode () modeEditComment++editUncomment :: IDEAction+editUncomment = withCurrentMode () modeEditUncomment++selectedModuleName :: IDEM (Maybe String)+selectedModuleName = withCurrentMode Nothing modeSelectedModuleName++editToCandy :: IDEAction+editToCandy = withCurrentMode () modeEditToCandy++editFromCandy :: IDEAction+editFromCandy = withCurrentMode () modeEditFromCandy++editKeystrokeCandy :: Maybe Char -> IDEAction+editKeystrokeCandy c = withCurrentMode () (\m -> modeEditKeystrokeCandy m c)+++++
+ src/IDE/Build.hs view
@@ -0,0 +1,225 @@+{-# OPTIONS_GHC #-}+-----------------------------------------------------------------------------+--+-- Module : IDE.Build+-- Copyright : (c) Juergen Nicklisch-Franken, Hamish Mackenzie+-- License : GNU-GPL+--+-- Maintainer : <maintainer at leksah.org>+-- Stability : provisional+-- Portability : portable+--+-- | Simple build system for packages+--+-------------------------------------------------------------------------------+++module IDE.Build (+ constrDepGraph, -- :: [IDEPackage] -> MakeGraph+ constrMakeChain, -- :: MakeSettings -> MakeGraph -> [IDEPackage] -> BuildChain MakeOp+ doBuildChain, -- :: BuildChain MakeOp -> IDE Bool+ makePackages,+ MakeSettings(..),+ MakeOp(..),+) where++import Data.Map (Map)+import IDE.Core.State+ (readIDE, IDEAction, Workspace(..), ipdPackageId, ipdDepends,+ IDEPackage)+import qualified Data.Map as Map+ (insert, empty, lookup, toList, fromList)+import Data.Graph+ (edges, topSort, graphFromEdges, Vertex, Graph,+ transposeG)+import Distribution.Package (pkgVersion, pkgName, Dependency(..))+import Data.List ((\\), nub, find)+import Distribution.Version (withinRange)+import Data.Maybe (mapMaybe)+import IDE.Package+ (packageClean', packageInstall', buildPackage, packageConfig')+import IDE.Core.Types (InstallFlag, IDE(..), WorkspaceAction)+import Control.Monad.Reader+import Distribution.Text (Text(..))++-- import Debug.Trace (trace)+trace a b = b+++-- ** Types++type MyGraph a = Map a [a]++type MakeGraph = MyGraph IDEPackage++-- | a make operation+data MakeOp =+ MoConfigure+ | MoBuild+ | MoInstall+ | MoClean+ | MoDocu+ | MoOther String+ | MoComposed [MakeOp]+ deriving Show++data Chain alpha beta =+ Chain {+ mcAction :: alpha,+ mcEle :: beta,+ mcPos :: Chain alpha beta,+ mcNeg :: Maybe (Chain alpha beta)}+ | EmptyChain+ deriving Show++data MakeSettings = MakeSettings {+ msInstallMode :: InstallFlag,+ msIsSingleMake :: Bool,+ msSaveAllBeforeBuild :: Bool,+ msBackgroundBuild :: Bool,+ msLinkingInBB :: Bool}++-- ** Functions++-- | Construct a dependency graph for a package+-- pointing to the packages the subject package depends on+constrParentGraph :: [IDEPackage] -> MakeGraph+constrParentGraph targets = trace ("parentGraph : " ++ showGraph parGraph) parGraph+ where+ parGraph = Map.fromList+ $ map (\ p -> (p,nub $ p : mapMaybe (depToTarget targets)(ipdDepends p))) targets++-- | Construct a dependency graph for a package+-- pointing to the packages which depend on the subject package+constrDepGraph :: [IDEPackage] -> MakeGraph+constrDepGraph packages = trace ("depGraph : " ++ showGraph depGraph) depGraph+ where+ depGraph = reverseGraph (constrParentGraph packages)++showGraph :: MakeGraph -> String+showGraph mg =+ show+ $ map (\(k,v) -> (disp (ipdPackageId k), (map (disp . ipdPackageId) v)))+ $ Map.toList mg++showTopSorted :: [IDEPackage] -> String+showTopSorted = show . map (disp .ipdPackageId)++-- | Construct a make chain for a package,+-- which is a plan of the build to perform.+-- Consumes settings, the workspace and a list of targets.+constrMakeChain :: MakeSettings -> Workspace -> [IDEPackage] -> MakeOp -> Chain MakeOp IDEPackage+constrMakeChain _ _ [] _ = EmptyChain+constrMakeChain ms@MakeSettings{msIsSingleMake = isSingle}+ Workspace{wsPackages = packages, wsNobuildPack = noBuilds} targets@(headTarget:restTargets) op+ | isSingle = chainFor headTarget ms op EmptyChain Nothing+ | otherwise = trace ("topsorted: " ++ showTopSorted topsorted) constrElem targets topsorted+ where+ depGraph = constrDepGraph packages+ topsorted = topSortGraph depGraph+ constrElem :: [IDEPackage] -> [IDEPackage] -> Chain MakeOp IDEPackage+ constrElem _ [] = trace ("constrElem: 1") EmptyChain+ constrElem [] _ = trace ("constrElem: 2")EmptyChain+ constrElem currentTargets (current:rest)+ | elem current currentTargets && not (elem headTarget noBuilds) =+ let dependends = case Map.lookup current depGraph of+ Nothing -> trace ("Build>>constrMakeChain: unknown package"+ ++ show current) []+ Just deps -> deps+ in trace ("constrElem: 3 " ++ show currentTargets ++ " "+ ++ show current ++ " " ++ show rest +++ " " ++ show dependends) $ chainFor current ms op+ (constrElem (nub $ currentTargets ++ dependends) rest) (Just EmptyChain)+ | otherwise = trace ("constrElem: 4 " ++ show currentTargets ++ " "+ ++ show current ++ " " ++ show rest)+ $ constrElem currentTargets rest++chainFor :: IDEPackage -> MakeSettings -> MakeOp -> Chain MakeOp IDEPackage+ -> Maybe (Chain MakeOp IDEPackage)+ -> Chain MakeOp IDEPackage+chainFor target settings (MoComposed (hdOp:[])) cont mbNegCont =+ chainFor target settings hdOp cont mbNegCont+chainFor target settings (MoComposed (hdOp:rest)) cont mbNegCont =+ chainFor target settings hdOp (chainFor target settings (MoComposed rest) cont mbNegCont)+ mbNegCont+chainFor target settings op cont mbNegCont = Chain {+ mcAction = op,+ mcEle = target,+ mcPos = cont,+ mcNeg = mbNegCont}++doBuildChain :: MakeSettings -> Chain MakeOp IDEPackage -> IDEAction+doBuildChain _ EmptyChain = return ()+doBuildChain ms chain@Chain{mcAction = MoConfigure} = do+ packageConfig' (mcEle chain) (constrCont ms (mcPos chain) (mcNeg chain))+doBuildChain ms chain@Chain{mcAction = MoBuild} = do+ buildPackage (msBackgroundBuild ms) (mcEle chain) (constrCont ms (mcPos chain) (mcNeg chain))+doBuildChain ms chain@Chain{mcAction = MoInstall} = do+ packageInstall' (mcEle chain) (constrCont ms (mcPos chain) (mcNeg chain))+doBuildChain ms chain@Chain{mcAction = MoClean} = do+ packageClean' (mcEle chain) (constrCont ms (mcPos chain) (mcNeg chain))+doBuildChain ms chain = doBuildChain ms (mcPos chain)++constrCont ms pos (Just neg) False = doBuildChain ms neg+constrCont ms pos _ _ = doBuildChain ms pos++makePackages :: MakeSettings -> [IDEPackage] -> MakeOp -> WorkspaceAction+makePackages ms targets op = do+ ws <- ask+ lift $ do+ prefs' <- readIDE prefs+ let plan = constrMakeChain ms ws targets op+ trace ("makeChain : " ++ show plan) $ doBuildChain ms plan+++-- | Calculates for every dependency a target (or not)++-- TODO+depToTarget :: [IDEPackage] -> Dependency -> Maybe IDEPackage+depToTarget list dep = find (doesMatch dep) list+ where+ doesMatch (Dependency name versionRange) thePack =+ name == pkgName (ipdPackageId thePack)+ && withinRange (pkgVersion (ipdPackageId thePack)) versionRange++reverseGraph :: Ord alpha => MyGraph alpha -> MyGraph alpha+reverseGraph = withIndexGraph transposeG++topSortGraph :: Ord alpha => MyGraph alpha -> [alpha]+topSortGraph myGraph = map ((\ (_,x,_)-> x) . lookup) $ topSort graph+ where+ (graph,lookup,_) = fromMyGraph myGraph++withIndexGraph :: Ord alpha => (Graph -> Graph) -> MyGraph alpha -> MyGraph alpha+withIndexGraph idxOp myGraph = toMyGraph (idxOp graph) lookup+ where+ (graph,lookup,_) = fromMyGraph myGraph++fromMyGraph :: Ord alpha => MyGraph alpha -> (Graph, Vertex -> ((), alpha , [alpha]), alpha -> Maybe Vertex)+fromMyGraph myGraph =+ graphFromEdges+ $ map (\(e,l)-> ((),e,l))+ $ graphList ++ map (\e-> (e,[])) missingEdges+ where+ mentionedEdges = nub $ concatMap snd graphList+ graphList = Map.toList myGraph+ missingEdges = mentionedEdges \\ map fst graphList++toMyGraph :: Ord alpha => Graph -> (Vertex -> ((), alpha, [alpha])) -> MyGraph alpha+toMyGraph graph lookup = foldr constr Map.empty myEdges+ where+ constr (from,to) map = case Map.lookup from map of+ Nothing -> Map.insert from [to] map+ Just l -> Map.insert from (to : l) map+ myEdges = map (\(a,b) -> (lookItUp a, lookItUp b)) $ edges graph+ lookItUp = (\(_,e,_)-> e) . lookup+++--calculateReverseDependencies ::+-- Workspace -> Map IDEPackage [IDEPackage]+--calculateReverseDependencies Workspace{wsPackages = wsPackages} = constrDepGraph wsPackages+++++
src/IDE/Command.hs view
@@ -19,6 +19,7 @@ mkActions , menuDescription , makeMenu+, canQuit , quit , aboutDialog , buildStatusbar@@ -26,7 +27,7 @@ , setSensitivity , updateRecentEntries , handleSpecialKeystrokes-, registerEvents+, registerLeksahEvents , instrumentWindow , instrumentSecWindow ) where@@ -41,7 +42,7 @@ aboutDialogSetLicense, aboutDialogSetComments, aboutDialogSetCopyright, aboutDialogSetVersion, aboutDialogSetName, aboutDialogNew, mainQuit, widgetHide, widgetShow,- widgetSetSensitive, castToWidget, separatorMenuItemNew,+ castToWidget, separatorMenuItemNew, containerGetChildren, Menu, widgetSetSizeRequest, toolbarSetStyle, toolbarSetIconSize, castToToolbar, castToMenuBar, uiManagerGetWidget, uiManagerGetAccelGroup, onActionActivate,@@ -71,16 +72,16 @@ import IDE.Session import IDE.Pane.Modules import IDE.Find+import IDE.Pane.Info import IDE.Utils.FileUtils import IDE.Utils.GUIUtils-import IDE.Pane.References import Paths_leksah import IDE.GUIHistory import IDE.Metainfo.Provider (getWorkspaceInfo, getIdentifierDescr, updateWorkspaceInfo, updateSystemInfo, rebuildSystemInfo, rebuildWorkspaceInfo) import IDE.NotebookFlipper-import IDE.ImportTool (addAllImports)+import IDE.ImportTool (resolveErrors) import IDE.LogRef import IDE.Debug import System.Directory (doesFileExist)@@ -108,7 +109,9 @@ mkActions :: [ActionDescr IDERef] mkActions = [AD "File" "_File" Nothing Nothing (return ()) [] False- ,AD "FileNew" "_New" Nothing (Just "gtk-new")+ ,AD "FileNew" "_New Module" Nothing (Just "gtk-new")+ (packageTry_ $ addModule []) [] False+ ,AD "FileNewTextFile" "_New Text File" Nothing Nothing fileNew [] False ,AD "FileOpen" "_Open" Nothing (Just "gtk-open") fileOpen [] False@@ -185,9 +188,9 @@ workspaceClose [] False ,AD "CleanWorkspace" "Cl_ean Workspace" (Just "Cleans all packages") (Just "ide_clean")- workspaceClean [] False+ (workspaceTry_ workspaceClean) [] False ,AD "MakeWorkspace" "_Make Workspace" (Just "Makes all of this workspace") (Just "ide_configure")- workspaceMake [] False+ (workspaceTry_ workspaceMake) [] False ,AD "NextError" "_Next Error" (Just "Go to the next error") (Just "ide_error_next") nextError [] False ,AD "PreviousError" "_Previous Error" (Just "Go to the previous error") (Just "ide_error_prev")@@ -195,46 +198,44 @@ ,AD "Package" "_Package" Nothing Nothing (return ()) [] False ,AD "NewPackage" "_New Package" Nothing Nothing- workspacePackageNew [] False+ (workspaceTry_ workspacePackageNew) [] False -- ,AD "RecentPackages" "_Recent Packages" Nothing Nothing (return ()) [] False ,AD "EditPackage" "_Edit Package" Nothing Nothing- packageEdit [] False+ (packageTry_ packageEdit) [] False -- ,AD "RemovePackage" "_Close Package" Nothing Nothing -- removePackage [] False ,AD "PackageFlags" "Edit Flags" (Just "Edit the package flags") Nothing (getFlags Nothing >>= \ p -> displayPane p False) [] False ,AD "CleanPackage" "Cl_ean Package" (Just "Cleans the package") (Just "ide_clean")- (packageClean Nothing) [] False+ (packageTry_ packageClean) [] False ,AD "ConfigPackage" "_Configure Package" (Just "Configures the package") (Just "ide_configure")- packageConfig [] False+ (packageTry_ packageConfig) [] False ,AD "BuildPackage" "_Build Package" (Just "Builds the package") (Just "ide_make")- makePackage [] False+ (packageTry_ makePackage) [] False ,AD "DocPackage" "_Build Documentation" (Just "Builds the documentation") Nothing- packageDoc [] False+ (packageTry_ packageDoc) [] False ,AD "CopyPackage" "_Copy Package" (Just "Copies the package") Nothing- packageCopy [] False+ (packageTry_ packageCopy) [] False ,AD "RunPackage" "_Run" (Just "Runs the package") (Just "ide_run")- packageRun [] False- ,AD "AddAllImports" "_Add All Imports" (Just "Resolve 'Not in scope' errors by adding the necessary imports") Nothing- addAllImports [] False+ (packageTry_ packageRun) [] False+ ,AD "ResolveErrors" "Resol_ve Errors" (Just "Resolve 'Hidden package' and 'Not in scope' errors by adding the necessary dependancies or imports") Nothing+ resolveErrors [] False ,AD "InstallPackage" "_Install Package" Nothing Nothing- packageInstall [] False+ (packageTry_ packageInstall) [] False ,AD "RegisterPackage" "_Register Package" Nothing Nothing- packageRegister [] False- ,AD "UnregisterPackage" "_Unregister" Nothing Nothing- packageUnregister [] False+ (packageTry_ packageRegister) [] False ,AD "TestPackage" "Test Package" Nothing Nothing- packageTest [] False+ (packageTry_ packageTest) [] False ,AD "SdistPackage" "Source Dist" Nothing Nothing- packageSdist [] False+ (packageTry_ packageSdist) [] False ,AD "OpenDocPackage" "_Open Doc" Nothing Nothing- packageOpenDoc [] False+ (packageTry_ 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+ (packageTry_ 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@@ -334,8 +335,6 @@ (getErrors Nothing >>= \ p -> displayPane p False) [] False ,AD "ShowLog" "Log" Nothing Nothing showLog [] False- ,AD "ShowReferences" "References" Nothing Nothing- (getReferences Nothing >>= \ p -> displayPane p False) [] False ,AD "ShowWorkspace" "Workspace" Nothing Nothing (getWorkspace Nothing >>= \ p -> displayPane p False) [] False @@ -411,7 +410,10 @@ ,AD "BackgroundLinkToggled" "_BackgroundLink" (Just "Link in the background") (Just "ide_link") backgroundLinkToggled [] True ,AD "DebugToggled" "_Debug" (Just "Use GHCi debugger to build and run") (Just "ide_debug")- debugToggled [] True]+ debugToggled [] True+ ,AD "OpenDocu" "_OpenDocu" (Just "Opens a browser for a search of the selected data") Nothing+ openDocu [] True+ ] -- -- | The menu description in XML Syntax as defined by GTK@@ -561,15 +563,19 @@ mapM_ widgetShow (castToWidget sep1 : castToWidget sep2 : otherEntries) mapM_ widgetHide $ take 2 (reverse items) +canQuit :: IDEM Bool+canQuit = do+ modifyIDE_ (\ide -> ide{currentState = IsShuttingDown})+ saveSession :: IDEAction+ can <- fileCloseAll (\_ -> return True)+ unless can $ modifyIDE_ (\ide -> ide{currentState = IsRunning})+ return can+ -- | Quit ide quit :: IDEAction quit = do- modifyIDE_ (\ide -> ide{currentState = IsShuttingDown})- saveSession :: IDEAction- b <- fileCloseAll (\_ -> return True)- if b- then liftIO mainQuit- else modifyIDE_ (\ide -> ide{currentState = IsRunning})+ can <- canQuit+ when can $ liftIO mainQuit -- -- | Show the about dialog@@ -579,7 +585,7 @@ d <- aboutDialogNew aboutDialogSetName d "Leksah" aboutDialogSetVersion d (showVersion version)- aboutDialogSetCopyright d "Copyright 2007-2010 Jürgen Nicklisch-Franken, Hamish Mackenzie"+ aboutDialogSetCopyright d "Copyright 2007-2011 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@@ -624,7 +630,7 @@ getActionsFor SensitivityProjectActive = getActionsFor' ["EditPackage", "PackageFlags", "ConfigPackage", "BuildPackage" ,"DocPackage", "CleanPackage", "CopyPackage", "RunPackage","InstallPackage"- ,"RegisterPackage", "UnregisterPackage","TestPackage","SdistPackage"+ ,"RegisterPackage", "TestPackage","SdistPackage" ,"OpenDocPackage","FileCloseAll"] getActionsFor SensitivityError = getActionsFor' ["NextError", "PreviousError"] getActionsFor SensitivityEditor = getActionsFor' ["EditUndo", "EditRedo", "EditGotoLine"@@ -684,7 +690,7 @@ windowAddAccelGroup win acc containerAdd win vb reflectIDE (do- setCandyState (isJust (sourceCandy prefs))+ setCandyState (fst (sourceCandy prefs)) setBackgroundBuildToggled (backgroundBuild prefs) setBackgroundLinkToggled (backgroundLink prefs)) ideR @@ -764,61 +770,66 @@ case filter (not . isReexported) (getIdentifierDescr symbol symbolTable1 symbolTable2) of [] -> return () a:[] -> selectIdentifier a+ a:b:[] -> if isJust (dscMbModu a) && dscMbModu a == dscMbModu b &&+ isNear (dscMbLocation a) (dscMbLocation b)+ then selectIdentifier a+ else setChoices [a,b] l -> setChoices l-+ where+ isNear (Just a) (Just b) = abs (locationSLine a - locationSLine b) <= 3+ isNear _ _ = False -- -- | Register handlers for IDE events ---registerEvents :: IDEAction-registerEvents = do+registerLeksahEvents :: IDEAction+registerLeksahEvents = do stRef <- ask registerEvent stRef "LogMessage"- (Left (\e@(LogMessage s t) -> getLog >>= \(log :: IDELog) -> liftIO $ appendLog log s t- >> return e))+ (\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))+ (\ e@(SelectInfo str) -> setSymbol str >> return e) registerEvent stRef "SelectIdent"- (Left (\ e@(SelectIdent id) -> selectIdentifier id >> return e))+ (\ e@(SelectIdent id) -> selectIdentifier id >> return e) registerEvent stRef "InfoChanged"- (Left (\ e@(InfoChanged b) -> reloadKeepSelection b >> return e))+ (\ e@(InfoChanged b) -> reloadKeepSelection b >> return e) registerEvent stRef "UpdateWorkspaceInfo"- (Left (\ e@UpdateWorkspaceInfo -> updateWorkspaceInfo >> return e))+ (\ e@UpdateWorkspaceInfo -> updateWorkspaceInfo >> return e) registerEvent stRef "WorkspaceChanged"- (Left (\ e@(WorkspaceChanged showPane updateFileCache)- -> updateWorkspace showPane updateFileCache >> return e))+ (\ e@(WorkspaceChanged showPane updateFileCache)+ -> updateWorkspace showPane updateFileCache >> return e) registerEvent stRef "RecordHistory"- (Left (\ rh@(RecordHistory h) -> recordHistory h >> return rh))+ (\ rh@(RecordHistory h) -> recordHistory h >> return rh) registerEvent stRef "Sensitivity"- (Left (\ s@(Sensitivity h) -> setSensitivity h >> return s))+ (\ s@(Sensitivity h) -> setSensitivity h >> return s) registerEvent stRef "SearchMeta"- (Left (\ e@(SearchMeta string) -> searchMetaGUI string >> return e))+ (\ e@(SearchMeta string) -> searchMetaGUI string >> return e) registerEvent stRef "LoadSession"- (Left (\ e@(LoadSession fp) -> loadSession fp >> return e))+ (\ e@(LoadSession fp) -> loadSession fp >> return e) registerEvent stRef "SaveSession"- (Left (\ e@(SaveSession fp) -> saveSessionAs fp Nothing >> return e))+ (\ e@(SaveSession fp) -> saveSessionAs fp Nothing >> return e) registerEvent stRef "UpdateRecent"- (Left (\ e@UpdateRecent -> updateRecentEntries >> return e))+ (\ e@UpdateRecent -> updateRecentEntries >> return e) registerEvent stRef "VariablesChanged"- (Left (\ e@VariablesChanged -> fillVariablesList >> return e))+ (\ e@VariablesChanged -> fillVariablesList >> return e) registerEvent stRef "ErrorChanged"- (Left (\ e@ErrorChanged -> postAsyncIDE fillErrorList >> return e))+ (\ e@ErrorChanged -> postAsyncIDE fillErrorList >> return e) registerEvent stRef "CurrentErrorChanged"- (Left (\ e@(CurrentErrorChanged mbLogRef) -> postAsyncIDE (do+ (\ e@(CurrentErrorChanged mbLogRef) -> postAsyncIDE (do selectRef mbLogRef- selectError mbLogRef) >> return e))+ selectError mbLogRef) >> return e) registerEvent stRef "BreakpointChanged"- (Left (\ e@BreakpointChanged -> postAsyncIDE fillBreakpointList >> return e))+ (\ e@BreakpointChanged -> postAsyncIDE fillBreakpointList >> return e) registerEvent stRef "CurrentBreakChanged"- (Left (\ e@(CurrentBreakChanged mbLogRef) -> postAsyncIDE (do+ (\ e@(CurrentBreakChanged mbLogRef) -> postAsyncIDE (do selectRef mbLogRef- selectBreak mbLogRef) >> return e))+ selectBreak mbLogRef) >> return e) registerEvent stRef "TraceChanged"- (Left (\ e@TraceChanged -> fillTraceList >> return e))+ (\ e@TraceChanged -> fillTraceList >> return e) registerEvent stRef "GetTextPopup"- (Left (\ e@(GetTextPopup _) -> return (GetTextPopup (Just textPopupMenu))))+ (\ e@(GetTextPopup _) -> return (GetTextPopup (Just textPopupMenu))) registerEvent stRef "StatusbarChanged"- (Left (\ e@(StatusbarChanged args)- -> changeStatusbar args >> return e))+ (\ e@(StatusbarChanged args) -> changeStatusbar args >> return e) return ()
src/IDE/Completion.hs view
@@ -1,3 +1,4 @@+{-# LANGUAGE ScopedTypeVariables #-} ----------------------------------------------------------------------------- -- -- Module : IDE.Completion@@ -12,11 +13,11 @@ -- ----------------------------------------------------------------------------- -module IDE.Completion (complete, cancel) where+module IDE.Completion (complete, cancel, setCompletionSize) where import Prelude hiding(getChar, getLine) -import Data.List as List hiding(insert)+import Data.List as List (stripPrefix, isPrefixOf, filter) import Data.Char import Data.IORef import Control.Monad@@ -30,49 +31,81 @@ complete :: EditorView -> Bool -> IDEAction complete sourceView always = do- currentState' <- readIDE currentState- prefs' <- readIDE prefs- completion' <- readIDE completion+ currentState' <- readIDE currentState+ prefs' <- readIDE prefs+ (_, completion') <- readIDE completion case (currentState',completion') of- (IsCompleting c, Just (CompletionWindow window tv st)) ->- updateOptions window tv st sourceView c+ (IsCompleting c, Just (CompletionWindow window tv st)) -> do+ isWordChar <- getIsWordChar sourceView+ updateOptions window tv st sourceView c isWordChar always (IsRunning,_) -> when (always || not (completeRestricted prefs'))- (initCompletion sourceView)+ (initCompletion sourceView always) _ -> return () cancel :: IDEAction cancel = do- currentState' <- readIDE currentState- completion' <- readIDE completion+ currentState' <- readIDE currentState+ (_, completion') <- readIDE completion case (currentState',completion') of (IsCompleting conn , Just (CompletionWindow window tv st)) -> cancelCompletion window tv st conn _ -> return () -initCompletion :: EditorView -> IDEAction-initCompletion sourceView = do+setCompletionSize :: (Int, Int) -> IDEAction+setCompletionSize (x, y) | x > 10 && y > 10 = do+ (_, completion) <- readIDE completion+ case completion of+ Just (CompletionWindow window _ _) -> liftIO $ windowResize window x y+ Nothing -> return ()+ modifyIDE_ $ \ide -> ide{completion = ((x, y), completion)}+setCompletionSize _ = return ()++getIsWordChar :: EditorView -> IDEM (Char -> Bool)+getIsWordChar sourceView = do ideR <- ask- completion' <- readIDE completion+ buffer <- getBuffer sourceView+ (_, end) <- getSelectionBounds buffer+ sol <- backwardToLineStartC end+ eol <- forwardToLineEndC end+ line <- getSlice buffer sol eol False++ let isImport = "import " `isPrefixOf` line+ isIdent a = isAlphaNum a || a == '\'' || a == '_' || (isImport && a == '.')+ isOp a = isSymbol a || a == ':' || a == '\\' || a == '*' || a == '/' || a == '-'+ || a == '!' || a == '@' || a == '%' || a == '&' || a == '?'+ prev <- backwardCharC end+ prevChar <- getChar prev+ case prevChar of+ Just prevChar | isIdent prevChar -> return isIdent+ Just prevChar | isOp prevChar -> return isOp+ _ -> return $ const False++initCompletion :: EditorView -> Bool -> IDEAction+initCompletion sourceView always = do+ ideR <- ask+ ((width, height), completion') <- readIDE completion+ isWordChar <- getIsWordChar sourceView case completion' of Just (CompletionWindow window' tree' store') -> do- cids <- addEventHandling window' sourceView tree' store'+ cids <- addEventHandling window' sourceView tree' store' isWordChar always modifyIDE_ (\ide -> ide{currentState = IsCompleting cids})- updateOptions window' tree' store' sourceView cids+ updateOptions window' tree' store' sourceView cids isWordChar always Nothing -> do windows <- getWindows prefs <- readIDE prefs- window <- liftIO $ do- windowNewPopup- liftIO $ set window [ windowTypeHint := WindowTypeHintUtility,- windowDecorated := False,- windowResizable := True ]- --liftIO $ widgetSetSizeRequest window 700 300- liftIO $ containerSetBorderWidth window 3+ window <- liftIO windowNewPopup liftIO $ windowSetTransientFor window (head windows)+ liftIO $ set window [+ windowTypeHint := WindowTypeHintUtility,+ windowDecorated := False,+ windowResizable := True,+ windowDefaultWidth := width,+ windowDefaultHeight := height]+ liftIO $ containerSetBorderWidth window 3 paned <- liftIO $ hPanedNew liftIO $ containerAdd window paned nameScrolledWindow <- liftIO $ scrolledWindowNew Nothing Nothing- liftIO $ widgetSetSizeRequest nameScrolledWindow 250 400+ liftIO $ widgetSetSizeRequest nameScrolledWindow 250 40 tree <- liftIO $ treeViewNew liftIO $ containerAdd nameScrolledWindow tree store <- liftIO $ listStoreNew []@@ -100,10 +133,11 @@ descriptionBuffer <- newGtkBuffer Nothing "" descriptionView <- newView descriptionBuffer (textviewFont prefs)- setStyle descriptionBuffer $ sourceStyle prefs+ setStyle descriptionBuffer $ case sourceStyle prefs of+ (False,_) -> Nothing+ (True,v) -> Just v descriptionScrolledWindow <- getScrolledWindow descriptionView - liftIO $ widgetSetSizeRequest descriptionScrolledWindow 500 400 visible <- liftIO $ newIORef False activeView <- liftIO $ newIORef Nothing @@ -124,14 +158,15 @@ liftIO $ panedAdd1 paned nameScrolledWindow liftIO $ panedAdd2 paned descriptionScrolledWindow - cids <- addEventHandling window sourceView tree store+ cids <- addEventHandling window sourceView tree store isWordChar always modifyIDE_ (\ide -> ide{currentState = IsCompleting cids,- completion = Just (CompletionWindow window tree store)})- updateOptions window tree store sourceView cids+ completion = ((width, height), Just (CompletionWindow window tree store))})+ updateOptions window tree store sourceView cids isWordChar always -addEventHandling :: Window -> EditorView -> TreeView -> ListStore String -> IDEM Connections-addEventHandling window sourceView tree store = do+addEventHandling :: Window -> EditorView -> TreeView -> ListStore String+ -> (Char -> Bool) -> Bool -> IDEM Connections+addEventHandling window sourceView tree store isWordChar always = do ideR <- ask cidsPress <- sourceView `onKeyPress` \name modifier keyVal -> do char <- liftIO $ keyvalToChar keyVal@@ -143,7 +178,7 @@ ("Tab", _, _) -> (do visible <- liftIO $ get tree widgetVisible if visible then (do- tryToUpdateOptions window tree store sourceView True+ tryToUpdateOptions window tree store sourceView True isWordChar always return True ) else return False@@ -192,7 +227,7 @@ ) else return False )- (_, _, Just c) | ((isAlphaNum c) || (c == '.') || (c == '_')) -> (do+ (_, _, Just c) | isWordChar c -> (do return False ) ("BackSpace", _, _) -> (do@@ -213,21 +248,50 @@ return False _ -> return False + resizeHandler <- liftIO $ newIORef Nothing+ idButtonPress <- liftIO $ window `on` buttonPressEvent $ do button <- eventButton (x, y) <- eventCoordinates time <- eventTime- (width, _) <- liftIO $ widgetGetSize window- liftIO $ windowBeginResizeDrag window- (if floor x < width `div` 2 then WindowEdgeSouthWest else WindowEdgeSouthEast)- button (floor x) (floor y) time++ drawWindow <- liftIO $ widgetGetDrawWindow window+ status <- liftIO $ pointerGrab+ drawWindow+ False+ [PointerMotionMask, ButtonReleaseMask]+ (Nothing::Maybe DrawWindow)+ Nothing+ time+ when (status == GrabSuccess) $ liftIO $ do+ (width, height) <- windowGetSize window+ writeIORef resizeHandler $ Just $ \(newX, newY) -> do+ reflectIDE (+ setCompletionSize ((width + (floor (newX - x))), (height + (floor (newY - y))))) ideR+ return True + idMotion <- liftIO $ window `on` motionNotifyEvent $ do+ mbResize <- liftIO $ readIORef resizeHandler+ case mbResize of+ Just resize -> eventCoordinates >>= (liftIO . resize) >> return True+ Nothing -> return False++ idButtonRelease <- liftIO $ window `on` buttonReleaseEvent $ do+ mbResize <- liftIO $ readIORef resizeHandler+ case mbResize of+ Just resize -> do+ eventCoordinates >>= (liftIO . resize)+ eventTime >>= (liftIO . pointerUngrab)+ liftIO $ writeIORef resizeHandler Nothing+ return True+ Nothing -> return False+ idSelected <- liftIO $ tree `onRowActivated` (\treePath column -> (do- reflectIDE (withWord store treePath (replaceWordStart sourceView)) ideR+ reflectIDE (withWord store treePath (replaceWordStart sourceView isWordChar)) ideR liftIO $ postGUIAsync $ reflectIDE cancel ideR)) - return $ concat [cidsPress, cidsRelease, [ConnectC idButtonPress, ConnectC idSelected]]+ return $ concat [cidsPress, cidsRelease, [ConnectC idButtonPress, ConnectC idMotion, ConnectC idButtonRelease, ConnectC idSelected]] withWord :: ListStore String -> TreePath -> (String -> IDEM ()) -> IDEM () withWord store treePath f = (do@@ -239,17 +303,22 @@ _ -> return () ) -replaceWordStart :: EditorView -> String -> IDEM ()-replaceWordStart sourceView name = do+replaceWordStart :: EditorView -> (Char -> Bool) -> String -> IDEM ()+replaceWordStart sourceView isWordChar name = do buffer <- getBuffer sourceView- (selStart, end) <- getSelectionBounds buffer- isWordEnd <- endsWord end- when isWordEnd $ do- start <- findWordStart selStart- wordStart <- getText buffer start end True- case stripPrefix wordStart name of- Just extra -> insert buffer end extra- Nothing -> return ()+ (selStart, selEnd) <- getSelectionBounds buffer+ start <- findWordStart selStart isWordChar+ wordStart <- getText buffer start selEnd True+ case stripPrefix wordStart name of+ Just extra -> do+ end <- findWordEnd selEnd isWordChar+ wordFinish <- getText buffer selEnd end True+ case (wordFinish, stripPrefix wordFinish extra) of+ (_:_,Just extra2) -> do+ selectRange buffer end end+ insert buffer end extra2+ _ -> insert buffer selEnd extra+ Nothing -> return () cancelCompletion :: Window -> TreeView -> ListStore String -> Connections -> IDEAction cancelCompletion window tree store connections = do@@ -260,18 +329,18 @@ ) modifyIDE_ (\ide -> ide{currentState = IsRunning}) -updateOptions :: Window -> TreeView -> ListStore String -> EditorView -> Connections -> IDEAction-updateOptions window tree store sourceView connections = do- result <- tryToUpdateOptions window tree store sourceView False+updateOptions :: Window -> TreeView -> ListStore String -> EditorView -> Connections -> (Char -> Bool) -> Bool -> IDEAction+updateOptions window tree store sourceView connections isWordChar always = do+ result <- tryToUpdateOptions window tree store sourceView False isWordChar always when (not result) $ cancelCompletion window tree store connections -tryToUpdateOptions :: Window -> TreeView -> ListStore String -> EditorView -> Bool -> IDEM Bool-tryToUpdateOptions window tree store sourceView selectLCP = do+tryToUpdateOptions :: Window -> TreeView -> ListStore String -> EditorView -> Bool -> (Char -> Bool) -> Bool -> IDEM Bool+tryToUpdateOptions window tree store sourceView selectLCP isWordChar always = do ideR <- ask liftIO $ listStoreClear (store :: ListStore String) buffer <- getBuffer sourceView (selStart, end) <- getSelectionBounds buffer- start <- findWordStart selStart+ start <- findWordStart selStart isWordChar equal <- iterEqual start end if equal then return False@@ -280,92 +349,94 @@ liftIO $ postGUIAsync $ do reflectIDE (do options <- getCompletionOptions wordStart- processResults window tree store sourceView wordStart options selectLCP) ideR+ processResults window tree store sourceView wordStart options selectLCP isWordChar always) ideR return () return True -findWordStart :: EditorIter -> IDEM EditorIter-findWordStart iter = do- maybeWS <- backwardWordStartC iter+findWordStart :: EditorIter -> (Char -> Bool) -> IDEM EditorIter+findWordStart iter isWordChar = do+ maybeWS <- backwardFindCharC iter (not . isWordChar) Nothing case maybeWS of Nothing -> atOffset iter 0- Just ws -> do- prev <- backwardCharC ws- maybeChar <- getChar prev- case maybeChar of- Just '_' -> findWordStart prev- _ -> return ws+ Just ws -> forwardCharC ws +findWordEnd :: EditorIter -> (Char -> Bool) -> IDEM EditorIter+findWordEnd iter isWordChar = do+ maybeWE <- forwardFindCharC iter (not . isWordChar) Nothing+ case maybeWE of+ Nothing -> forwardToLineEndC iter+ Just we -> return we+ longestCommonPrefix (x:xs) (y:ys) | x == y = x : longestCommonPrefix xs ys longestCommonPrefix _ _ = [] -processResults :: Window -> TreeView -> ListStore String -> EditorView -> String -> [String] -> Bool -> IDEAction-processResults window tree store sourceView wordStart options selectLCP = do+processResults :: Window -> TreeView -> ListStore String -> EditorView -> String -> [String]+ -> Bool -> (Char -> Bool) -> Bool -> IDEAction+processResults window tree store sourceView wordStart options selectLCP isWordChar always = do case options of [] -> cancel- _ -> do+ _ | not always && (not . null $ drop 200 options) -> cancel+ _ -> do buffer <- getBuffer sourceView (selStart, end) <- getSelectionBounds buffer- isWordEnd <- endsWord end- when isWordEnd $ do- start <- findWordStart selStart- currentWordStart <- getText buffer start end True- newWordStart <- do- if selectLCP && currentWordStart == wordStart && (not $ null options)- then do- let lcp = foldl1 longestCommonPrefix options- return lcp- else- return currentWordStart+ start <- findWordStart selStart isWordChar+ currentWordStart <- getText buffer start end True+ newWordStart <- do+ if selectLCP && currentWordStart == wordStart && (not $ null options)+ then do+ let lcp = foldl1 longestCommonPrefix options+ return lcp+ else+ return currentWordStart - when (isPrefixOf wordStart newWordStart) $ do- liftIO $ listStoreClear store- let newOptions = List.filter (isPrefixOf newWordStart) options- liftIO $ forM_ (take 200 newOptions) (listStoreAppend store)- Rectangle startx starty width height <- getIterLocation sourceView start- (wWindow, hWindow) <- liftIO $ windowGetSize window- (x, y) <- bufferToWindowCoords sourceView (startx, starty+height)- drawWindow <- getDrawWindow sourceView- (ox, oy) <- liftIO $ drawWindowGetOrigin drawWindow- Just namesSW <- liftIO $ widgetGetParent tree- (wNames, hNames) <- liftIO $ widgetGetSize namesSW- Just paned <- liftIO $ widgetGetParent namesSW- Just first <- liftIO $ panedGetChild1 (castToPaned paned)- Just second <- liftIO $ panedGetChild2 (castToPaned paned)- screen <- liftIO $ windowGetScreen window- monitor <- liftIO $ screenGetMonitorAtPoint screen (ox+x) (oy+y)- monitorLeft <- liftIO $ screenGetMonitorAtPoint screen (ox+x-wWindow+wNames) (oy+y)- monitorRight <- liftIO $ screenGetMonitorAtPoint screen (ox+x+wWindow) (oy+y)- monitorBelow <- liftIO $ screenGetMonitorAtPoint screen (ox+x) (oy+y+hWindow)- wScreen <- liftIO $ screenGetWidth screen- hScreen <- liftIO $ screenGetHeight screen- top <- if monitorBelow /= monitor || (oy+y+hWindow) > hScreen- then do- sourceSW <- getScrolledWindow sourceView- (_, hSource) <- liftIO $ widgetGetSize sourceSW- scrollToIter sourceView end 0.1 (Just (1.0, 1.0 - (fromIntegral hWindow / fromIntegral hSource)))- (_, newy) <- bufferToWindowCoords sourceView (startx, starty+height)- return (oy+newy)- else return (oy+y)- swap <- if (monitorRight /= monitor || (ox+x+wWindow) > wScreen) && monitorLeft == monitor && (ox+x-wWindow+wNames) > 0- then do- liftIO $ windowMove window (ox+x-wWindow+wNames) top- return $ first == namesSW- else do- liftIO $ windowMove window (ox+x) top- return $ first /= namesSW- when swap $ liftIO $ do- pos <- panedGetPosition (castToPaned paned)- containerRemove (castToPaned paned) first- containerRemove (castToPaned paned) second- panedAdd1 (castToPaned paned) second- panedAdd2 (castToPaned paned) first- panedSetPosition (castToPaned paned) (wWindow-pos)- when (not $ null newOptions) $ liftIO $ treeViewSetCursor tree [0] Nothing- liftIO $ widgetShowAll window+ when (isPrefixOf wordStart newWordStart) $ do+ liftIO $ listStoreClear store+ let newOptions = List.filter (isPrefixOf newWordStart) options+ liftIO $ forM_ (take 200 newOptions) (listStoreAppend store)+ Rectangle startx starty width height <- getIterLocation sourceView start+ (wWindow, hWindow) <- liftIO $ windowGetSize window+ (x, y) <- bufferToWindowCoords sourceView (startx, starty+height)+ drawWindow <- getDrawWindow sourceView+ (ox, oy) <- liftIO $ drawWindowGetOrigin drawWindow+ Just namesSW <- liftIO $ widgetGetParent tree+ (wNames, hNames) <- liftIO $ widgetGetSize namesSW+ Just paned <- liftIO $ widgetGetParent namesSW+ Just first <- liftIO $ panedGetChild1 (castToPaned paned)+ Just second <- liftIO $ panedGetChild2 (castToPaned paned)+ screen <- liftIO $ windowGetScreen window+ monitor <- liftIO $ screenGetMonitorAtPoint screen (ox+x) (oy+y)+ monitorLeft <- liftIO $ screenGetMonitorAtPoint screen (ox+x-wWindow+wNames) (oy+y)+ monitorRight <- liftIO $ screenGetMonitorAtPoint screen (ox+x+wWindow) (oy+y)+ monitorBelow <- liftIO $ screenGetMonitorAtPoint screen (ox+x) (oy+y+hWindow)+ wScreen <- liftIO $ screenGetWidth screen+ hScreen <- liftIO $ screenGetHeight screen+ top <- if monitorBelow /= monitor || (oy+y+hWindow) > hScreen+ then do+ sourceSW <- getScrolledWindow sourceView+ (_, hSource) <- liftIO $ widgetGetSize sourceSW+ scrollToIter sourceView end 0.1 (Just (1.0, 1.0 - (fromIntegral hWindow / fromIntegral hSource)))+ (_, newy) <- bufferToWindowCoords sourceView (startx, starty+height)+ return (oy+newy)+ else return (oy+y)+ swap <- if (monitorRight /= monitor || (ox+x+wWindow) > wScreen) && monitorLeft == monitor && (ox+x-wWindow+wNames) > 0+ then do+ liftIO $ windowMove window (ox+x-wWindow+wNames) top+ return $ first == namesSW+ else do+ liftIO $ windowMove window (ox+x) top+ return $ first /= namesSW+ when swap $ liftIO $ do+ pos <- panedGetPosition (castToPaned paned)+ containerRemove (castToPaned paned) first+ containerRemove (castToPaned paned) second+ panedAdd1 (castToPaned paned) second+ panedAdd2 (castToPaned paned) first+ panedSetPosition (castToPaned paned) (wWindow-pos)+ when (not $ null newOptions) $ liftIO $ treeViewSetCursor tree [0] Nothing+ liftIO $ widgetShowAll window - when (newWordStart /= currentWordStart) $- replaceWordStart sourceView newWordStart+ when (newWordStart /= currentWordStart) $+ replaceWordStart sourceView isWordChar newWordStart getRow tree = do Just model <- treeViewGetModel tree
src/IDE/Core/State.hs view
@@ -61,10 +61,8 @@ --, closePane , activeProjectDir -#ifdef YI , liftYiControl , liftYi-#endif , module IDE.Core.Types , module IDE.Core.CTypes@@ -94,12 +92,7 @@ import IDE.Utils.Utils import qualified Data.Map as Map (lookup) import Data.Typeable(Typeable)--#ifdef YI-import qualified Yi as Yi-import qualified Yi.UI.Pango.Control as Yi-#endif-+import qualified IDE.YiConfig as Yi instance PaneMonad IDEM where getFrameState = readIDE frameState@@ -276,7 +269,7 @@ isInterpreting :: IDEM Bool isInterpreting = do- readIDE ghciState >>= \mb -> return (isJust mb)+ readIDE debugState >>= \mb -> return (isJust mb) triggerEventIDE :: IDEEvent -> IDEM IDEEvent triggerEventIDE e = ask >>= \ideR -> triggerEvent ideR e@@ -291,8 +284,6 @@ reflectIDE :: IDEM a -> IDERef -> IO a reflectIDE c ideR = runReaderT c ideR -#ifdef YI- liftYiControl :: Yi.ControlM a -> IDEM a liftYiControl f = do control <- readIDE yiControl@@ -300,8 +291,6 @@ liftYi :: Yi.YiM a -> IDEM a liftYi = liftYiControl . Yi.liftYi--#endif catchIDE :: Exception e => IDEM a -> (e -> IO a) -> IDEM a catchIDE block handler = reifyIDE (\ideR -> catch (reflectIDE block ideR) handler)
src/IDE/Core/Types.hs view
@@ -32,7 +32,20 @@ , IDEM , IDEAction , IDEEvent(..)+, liftIDE +, WorkspaceM+, WorkspaceAction+, runWorkspace++, PackageM+, PackageAction+, runPackage++, DebugM+, DebugAction+, runDebug+ , IDEPackage(..) , Workspace(..) @@ -72,9 +85,7 @@ , StatusbarCompartment(..) ) where -#ifdef YI-import Yi.UI.Pango.Control as Yi-#endif+import qualified IDE.YiConfig as Yi import Graphics.UI.Gtk (Window(..), KeyVal(..), Color(..), Menu(..), TreeView(..), ListStore(..), Toolbar(..))@@ -99,10 +110,12 @@ import Numeric (showHex) import Control.Event (EventSelector(..), EventSource(..), Event(..))-import System.FilePath ((</>))+import System.FilePath (dropFileName, (</>)) import IDE.Core.CTypes import IDE.StrippedPrefs(RetrieveStrategy) import System.IO (Handle)+import Distribution.Text(disp)+import Text.PrettyPrint (render) -- --------------------------------------------------------------------- -- IDE State@@ -136,11 +149,9 @@ , recentFiles :: [FilePath] , recentWorkspaces :: [FilePath] , runningTool :: Maybe ProcessHandle-, ghciState :: Maybe ToolState-, completion :: Maybe CompletionWindow-#ifdef YI+, debugState :: Maybe (IDEPackage, ToolState)+, completion :: ((Int, Int), Maybe CompletionWindow) , yiControl :: Yi.Control-#endif , server :: Maybe Handle } --deriving Show @@ -174,7 +185,37 @@ | IsCompleting Connections +liftIDE :: IDEM a -> WorkspaceM a+liftIDE = lift+ -- ---------------------------------------------------------------------+-- Monad for functions that need an open workspace+--+type WorkspaceM = ReaderT Workspace IDEM+type WorkspaceAction = WorkspaceM ()++runWorkspace :: WorkspaceM a -> Workspace -> IDEM a+runWorkspace = runReaderT++-- ---------------------------------------------------------------------+-- Monad for functions that need an active package+--+type PackageM = ReaderT IDEPackage IDEM+type PackageAction = PackageM ()++runPackage :: PackageM a -> IDEPackage -> IDEM a+runPackage = runReaderT++-- ---------------------------------------------------------------------+-- Monad for functions that need to use the GHCi debugger+--+type DebugM = ReaderT (IDEPackage, ToolState) IDEM+type DebugAction = DebugM ()++runDebug :: DebugM a -> (IDEPackage, ToolState) -> IDEM a+runDebug = runReaderT++-- --------------------------------------------------------------------- -- Events which can be signalled and handled -- @@ -266,7 +307,7 @@ , ipdModules :: Set ModuleName , ipdMain :: [FilePath] , ipdExtraSrcs :: Set FilePath-, ipdSrcDirs :: [FilePath]+, ipdSrcDirs :: [FilePath] , ipdExtensions :: [Extension] , ipdConfigFlags :: [String] , ipdBuildFlags :: [String]@@ -277,8 +318,11 @@ , ipdUnregisterFlags :: [String] , ipdSdistFlags :: [String] }- deriving (Eq,Show)+ deriving (Eq) +instance Show IDEPackage where+ show p = show "IDEPackage for " ++ (render . disp) (ipdPackageId p)+ instance Ord IDEPackage where compare x y = compare (ipdPackageId x) (ipdPackageId y) @@ -291,10 +335,9 @@ , wsName :: String , wsFile :: FilePath , wsPackages :: [IDEPackage]-, wsActivePack :: Maybe IDEPackage , wsPackagesFiles :: [FilePath] , wsActivePackFile:: Maybe FilePath-, wsReverseDeps :: Map IDEPackage [IDEPackage]+, wsNobuildPack :: [IDEPackage] } deriving Show -- ---------------------------------------------------------------------@@ -325,17 +368,19 @@ prefsFormat :: Int , prefsSaveTime :: String , showLineNumbers :: Bool- , rightMargin :: Maybe Int+ , rightMargin :: (Bool, Int) , tabWidth :: Int- , sourceCandy :: Maybe String+ , wrapLines :: Bool+ , sourceCandy :: (Bool,String) , keymapName :: String , forceLineEnds :: Bool , removeTBlanks :: Bool , textviewFont :: Maybe String- , sourceStyle :: Maybe String+ , sourceStyle :: (Bool, String) , foundBackground :: Color , contextBackground :: Color , breakpointBackground :: Color+ , autoLoad :: Bool , useYi :: Bool , logviewFont :: Maybe String , defaultSize :: (Int,Int)@@ -382,7 +427,7 @@ data LogRef = LogRef { logRefSrcSpan :: SrcSpan-, logRefRootPath :: FilePath+, logRefPackage :: IDEPackage , refDescription :: String , logLines :: (Int,Int) , logRefType :: LogRefType@@ -400,6 +445,8 @@ else show (srcSpanStartLine s) ++ ":" ++ show (srcSpanStartColumn s) ++ "-" ++ show (srcSpanEndColumn s) +logRefRootPath :: LogRef -> FilePath+logRefRootPath = dropFileName . ipdCabalFile . logRefPackage logRefFilePath :: LogRef -> FilePath logRefFilePath = srcSpanFilename . logRefSrcSpan
src/IDE/Debug.hs view
@@ -79,38 +79,45 @@ import Data.List (isSuffixOf) import IDE.System.Process (interruptProcessGroup) import IDE.Utils.GUIUtils (getDebugToggled)-import IDE.Package (debugStart, executeDebugCommand, printBindResultFlag, breakOnErrorFlag,- breakOnExceptionFlag, printEvldWithShowFlag)+import IDE.Package (debugStart, executeDebugCommand, tryDebug_, printBindResultFlag,+ breakOnErrorFlag, breakOnExceptionFlag, printEvldWithShowFlag) import IDE.Utils.Tool (ToolOutput(..), toolProcess)+import IDE.Workspaces (packageTry_) -debugCommand :: String -> ([ToolOutput] -> IDEAction) -> IDEAction+debugCommand :: String -> ([ToolOutput] -> IDEAction) -> DebugAction debugCommand command handler = debugCommand' command (\to -> do handler to triggerEventIDE VariablesChanged return ()) -debugCommand' :: String -> ([ToolOutput] -> IDEAction) -> IDEAction+debugCommand' :: String -> ([ToolOutput] -> IDEAction) -> DebugAction debugCommand' command handler = do- ideR <- ask- catchIDE (executeDebugCommand command handler)+ ghci <- ask+ lift $ catchIDE (runDebug (executeDebugCommand command handler) ghci) (\(e :: SomeException) -> putStrLn (show e)) debugToggled :: IDEAction debugToggled = do toggled <- getDebugToggled- if toggled- then debugStart- else debugQuit+ maybeDebug <- readIDE debugState+ case (toggled, maybeDebug) of+ (True, Nothing) -> packageTry_ $ debugStart+ (False, Just _) -> debugQuit+ _ -> return () debugQuit :: IDEAction-debugQuit = debugCommand ":quit" logOutput+debugQuit = do+ maybeDebug <- readIDE debugState+ case maybeDebug of+ Just debug -> runDebug (debugCommand ":quit" logOutput) debug+ _ -> return () debugExecuteSelection :: IDEAction debugExecuteSelection = do maybeText <- selectedTextOrCurrentLine case maybeText of- Just text -> do+ Just text -> packageTry_ $ tryDebug_ $ do debugSetLiberalScope debugCommand text logOutput Nothing -> ideMessage Normal "Please select some text in the editor to execute"@@ -119,7 +126,7 @@ debugExecuteAndShowSelection = do maybeText <- selectedTextOrCurrentLine case maybeText of- Just text -> do+ Just text -> packageTry_ $ tryDebug_ $ do debugSetLiberalScope debugCommand text (\to -> do insertTextAfterSelection $ " " ++ buildOutputString to@@ -132,14 +139,14 @@ buildOutputString (_:r) = buildOutputString r buildOutputString [] = "" -debugSetLiberalScope :: IDEAction+debugSetLiberalScope :: DebugAction debugSetLiberalScope = do- maybeModuleName <- selectedModuleName+ maybeModuleName <- lift selectedModuleName case maybeModuleName of Just moduleName -> do debugCommand (":module *" ++ moduleName) (\ _ -> return ()) Nothing -> do- mbPackage <- getActivePackageDescr+ mbPackage <- lift getActivePackageDescr case mbPackage of Nothing -> return () Just p -> let packageNames = map (display . modu . mdModuleId) (pdModules p)@@ -147,44 +154,49 @@ (\ _ -> return ()) debugAbandon :: IDEAction-debugAbandon = debugCommand ":abandon" logOutput+debugAbandon = packageTry_ $ tryDebug_ $ debugCommand ":abandon" logOutput debugBack :: IDEAction-debugBack = do- currentHist' <- readIDE currentHist- rootPath <- activeProjectDir- modifyIDE_ (\ide -> ide{currentHist = min (currentHist' - 1) 0})- debugCommand ":back" (logOutputForHistoricContext rootPath)+debugBack = packageTry_ $ do+ currentHist' <- lift $ readIDE currentHist+ rootPath <- lift activeProjectDir+ lift $ modifyIDE_ (\ide -> ide{currentHist = min (currentHist' - 1) 0})+ tryDebug_ $ do+ (debugPackage, _) <- ask+ debugCommand ":back" (logOutputForHistoricContext debugPackage) debugForward :: IDEAction-debugForward = do- currentHist' <- readIDE currentHist- rootPath <- activeProjectDir- modifyIDE_ (\ide -> ide{currentHist = currentHist' + 1})- debugCommand ":forward" (logOutputForHistoricContext rootPath)-+debugForward = packageTry_ $ do+ currentHist' <- lift $ readIDE currentHist+ rootPath <- lift activeProjectDir+ lift $ modifyIDE_ (\ide -> ide{currentHist = currentHist' + 1})+ tryDebug_ $ do+ (debugPackage, _) <- ask+ debugCommand ":forward" (logOutputForHistoricContext debugPackage) debugStop :: IDEAction debugStop = do- maybeGhci <- readIDE ghciState- liftIO $ case maybeGhci of- Just ghci -> toolProcess ghci >>= interruptProcessGroup+ maybeDebug <- readIDE debugState+ liftIO $ case maybeDebug of+ Just (_, ghci) -> toolProcess ghci >>= interruptProcessGroup Nothing -> return () debugContinue :: IDEAction-debugContinue = do- rootPath <- activeProjectDir- debugCommand ":continue" (logOutputForLiveContext rootPath)+debugContinue = packageTry_ $ do+ rootPath <- lift $ activeProjectDir+ tryDebug_ $ do+ (debugPackage, _) <- ask+ debugCommand ":continue" (logOutputForLiveContext debugPackage) debugDeleteAllBreakpoints :: IDEAction debugDeleteAllBreakpoints = do- debugCommand ":delete *" $ \output -> do+ packageTry_ $ tryDebug_ $ debugCommand ":delete *" $ \output -> do logOutput output setBreakpointList [] debugDeleteBreakpoint :: String -> LogRef -> IDEAction debugDeleteBreakpoint indexString lr = do- debugCommand (":delete " ++ indexString) $ \output -> do+ packageTry_ $ tryDebug_ $ debugCommand (":delete " ++ indexString) $ \output -> do logOutput output bl <- readIDE breakpointRefs setBreakpointList $ filter (/= lr) bl@@ -195,95 +207,111 @@ debugForce = do maybeText <- selectedTextOrCurrentLine case maybeText of- Just text -> debugCommand (":force " ++ text) logOutput+ Just text -> packageTry_ $ tryDebug_ $ debugCommand (":force " ++ text) logOutput Nothing -> ideMessage Normal "Please select an expression in the editor" debugHistory :: IDEAction-debugHistory = debugCommand ":history" logOutput+debugHistory = packageTry_ $ tryDebug_ $ debugCommand ":history" logOutput debugPrint :: IDEAction debugPrint = do maybeText <- selectedTextOrCurrentLine case maybeText of- Just text -> debugCommand (":print " ++ text) logOutput+ Just text -> packageTry_ $ tryDebug_ $ debugCommand (":print " ++ text) logOutput Nothing -> ideMessage Normal "Please select an name in the editor" debugSimplePrint :: IDEAction debugSimplePrint = do maybeText <- selectedTextOrCurrentLine case maybeText of- Just text -> debugCommand (":force " ++ text) logOutput+ Just text -> packageTry_ $ tryDebug_ $ debugCommand (":force " ++ text) logOutput Nothing -> ideMessage Normal "Please select an name in the editor" debugStep :: IDEAction-debugStep = do- rootPath <- activeProjectDir- debugSetLiberalScope- debugCommand ":step" (logOutputForLiveContext rootPath)+debugStep = packageTry_ $ do+ rootPath <- lift $ activeProjectDir+ tryDebug_ $ do+ (debugPackage, _) <- ask+ debugSetLiberalScope+ debugCommand ":step" (logOutputForLiveContext debugPackage) debugStepExpression :: IDEAction debugStepExpression = do maybeText <- selectedTextOrCurrentLine- debugSetLiberalScope- debugStepExpr maybeText+ packageTry_ $ tryDebug_ $ do+ debugSetLiberalScope+ debugStepExpr maybeText -debugStepExpr :: Maybe String -> IDEAction+debugStepExpr :: Maybe String -> DebugAction debugStepExpr maybeText = do- rootPath <- activeProjectDir+ (debugPackage, _) <- ask+ rootPath <- lift $ activeProjectDir case maybeText of- Just text -> debugCommand (":step " ++ text) (logOutputForLiveContext rootPath)- Nothing -> ideMessage Normal "Please select an expression in the editor"+ Just text -> debugCommand (":step " ++ text) (logOutputForLiveContext debugPackage)+ Nothing -> lift $ ideMessage Normal "Please select an expression in the editor" debugStepLocal :: IDEAction-debugStepLocal = do- rootPath <- activeProjectDir- debugCommand ":steplocal" (logOutputForLiveContext rootPath)+debugStepLocal = packageTry_ $ do+ rootPath <- lift $ activeProjectDir+ tryDebug_ $ do+ (debugPackage, _) <- ask+ debugCommand ":steplocal" (logOutputForLiveContext debugPackage) debugStepModule :: IDEAction-debugStepModule = do- rootPath <- activeProjectDir- debugCommand ":stepmodule" (logOutputForLiveContext rootPath)+debugStepModule = packageTry_ $ do+ rootPath <- lift $ activeProjectDir+ tryDebug_ $ do+ (debugPackage, _) <- ask+ debugCommand ":stepmodule" (logOutputForLiveContext debugPackage) debugTrace :: IDEAction-debugTrace = do- rootPath <- activeProjectDir- debugCommand ":trace" (\to -> do- logOutputForLiveContext rootPath to- triggerEventIDE TraceChanged- return ())+debugTrace = packageTry_ $ do+ rootPath <- lift $ activeProjectDir+ tryDebug_ $ do+ (debugPackage, _) <- ask+ debugCommand ":trace" (\to -> do+ logOutputForLiveContext debugPackage to+ triggerEventIDE TraceChanged+ return ()) debugTraceExpression :: IDEAction debugTraceExpression = do maybeText <- selectedTextOrCurrentLine- debugSetLiberalScope- debugTraceExpr maybeText+ packageTry_ $ tryDebug_ $ do+ debugSetLiberalScope+ debugTraceExpr maybeText -debugTraceExpr :: Maybe String -> IDEAction-debugTraceExpr maybeText =+debugTraceExpr :: Maybe String -> DebugAction+debugTraceExpr maybeText = do+ (debugPackage, _) <- ask case maybeText of Just text -> debugCommand (":trace " ++ text) (\to -> do rootPath <- activeProjectDir- logOutputForLiveContext rootPath to+ logOutputForLiveContext debugPackage to triggerEventIDE TraceChanged return ())- Nothing -> ideMessage Normal "Please select an expression in the editor"+ Nothing -> lift $ ideMessage Normal "Please select an expression in the editor" debugShowBindings :: IDEAction-debugShowBindings = debugCommand ":show bindings" logOutput+debugShowBindings = packageTry_ $ tryDebug_ $ debugCommand ":show bindings" logOutput debugShowBreakpoints :: IDEAction-debugShowBreakpoints = do- rootPath <- activeProjectDir- debugCommand ":show breaks" (logOutputForBreakpoints rootPath)+debugShowBreakpoints = packageTry_ $ do+ rootPath <- lift activeProjectDir+ tryDebug_ $ do+ (debugPackage, _) <- ask+ debugCommand ":show breaks" (logOutputForBreakpoints debugPackage) debugShowContext :: IDEAction-debugShowContext = do- rootPath <- activeProjectDir- debugCommand ":show context" (logOutputForLiveContext rootPath)+debugShowContext = packageTry_ $ do+ rootPath <- lift activeProjectDir+ tryDebug_ $ do+ (debugPackage, _) <- ask+ debugCommand ":show context" (logOutputForLiveContext debugPackage) debugShowModules :: IDEAction-debugShowModules = debugCommand ":show modules" $+debugShowModules = packageTry_ $ tryDebug_ $ debugCommand ":show modules" $ logOutputLines_ $ \log output -> liftIO $ do case output of ToolInput line -> appendLog log (line ++ "\n") InputTag@@ -296,16 +324,16 @@ return () debugShowPackages :: IDEAction-debugShowPackages = debugCommand ":show packages" logOutput+debugShowPackages = packageTry_ $ tryDebug_ $ debugCommand ":show packages" logOutput debugShowLanguages :: IDEAction-debugShowLanguages = debugCommand ":show languages" logOutput+debugShowLanguages = packageTry_ $ tryDebug_ $ debugCommand ":show languages" logOutput debugInformation :: IDEAction debugInformation = do maybeText <- selectedTextOrCurrentLine case maybeText of- Just text -> do+ Just text -> packageTry_ $ tryDebug_ $ do debugSetLiberalScope debugCommand (":info "++text) logOutput Nothing -> ideMessage Normal "Please select a name in the editor"@@ -314,7 +342,7 @@ debugKind = do maybeText <- selectedTextOrCurrentLine case maybeText of- Just text -> do+ Just text -> packageTry_ $ tryDebug_ $ do debugSetLiberalScope debugCommand (":kind "++text) logOutput Nothing -> ideMessage Normal "Please select a type in the editor"@@ -323,7 +351,7 @@ debugType = do maybeText <- selectedTextOrCurrentLine case maybeText of- Just text -> do+ Just text -> packageTry_ $ tryDebug_ $ do debugSetLiberalScope debugCommand (":type "++text) logOutput Nothing -> ideMessage Normal "Please select an expression in the editor"@@ -337,15 +365,17 @@ -- ### debugCommand (":add *"++moduleName) $ logOutputForBuild True maybeText <- selectedText case maybeText of- Just text -> do+ Just text -> packageTry_ $ tryDebug_ $ do+ (debugPackage, _) <- ask debugCommand (":module *" ++ moduleName) logOutput- debugCommand (":break " ++ text) (logOutputForSetBreakpoint rootPath)+ debugCommand (":break " ++ text) (logOutputForSetBreakpoint debugPackage) Nothing -> do maybeLocation <- selectedLocation case maybeLocation of- Just (line, lineOffset) ->+ Just (line, lineOffset) -> packageTry_ $ tryDebug_ $ do+ (debugPackage, _) <- ask debugCommand (":break " ++ moduleName ++ " " ++ (show (line+1)) ++ " " ++- (show lineOffset)) (logOutputForSetBreakpoint rootPath)+ (show lineOffset)) (logOutputForSetBreakpoint debugPackage) Nothing -> ideMessage Normal "Unknown error setting breakpoint" ref <- ask return ()@@ -353,7 +383,7 @@ debugSet :: (Bool -> String) -> Bool -> IDEAction debugSet flag value = do- debugCommand (":set "++(flag value)) logOutput+ packageTry_ $ tryDebug_ $ debugCommand (":set "++(flag value)) logOutput debugSetPrintEvldWithShow :: Bool -> IDEAction debugSetPrintEvldWithShow = debugSet printEvldWithShowFlag
src/IDE/Find.hs view
@@ -66,13 +66,13 @@ import Text.Regex.TDFA hiding (caseSensitive) import qualified Text.Regex.TDFA as Regex import Text.Regex.TDFA.String (compile)-import Data.List (nub, find, isPrefixOf)+import Data.List (find, isPrefixOf) import Data.Array (bounds, (!), inRange) import IDE.Utils.Tool (runTool) import Control.Concurrent (forkIO) import IDE.Pane.Grep import IDE.Package (getPackageDescriptionAndPath)-import Distribution.PackageDescription (allBuildInfo, hsSourceDirs)+import IDE.Workspaces (packageTry_) import System.FilePath (dropFileName) data FindState = FindState {@@ -205,7 +205,7 @@ grepButton <- toolButtonNew (Nothing :: Maybe Widget) (Just "Grep") toolbarInsert toolbar grepButton 0- grepButton `onToolButtonClicked` (reflectIDE (doGrep toolbar) ideR)+ grepButton `onToolButtonClicked` (reflectIDE (packageTry_ $ doGrep toolbar) ideR) tooltipsSetTip tooltips grepButton "Search in multiple files" "" sep1 <- separatorToolItemNew@@ -289,7 +289,7 @@ tooltipsSetTip tooltips entireWordButton "When selected only entire words are matched" "" caseSensitiveButton <- toggleToolButtonNew- toolButtonSetLabel caseSensitiveButton (Just "c. S.")+ toolButtonSetLabel caseSensitiveButton (Just "Case") widgetSetName caseSensitiveButton "caseSensitiveButton" toolbarInsert toolbar caseSensitiveButton 0 caseSensitiveButton `onToolButtonClicked` (doSearch toolbar Insert ideR)@@ -390,9 +390,10 @@ reflectIDE (addToHist search) ideR return () -doGrep :: Toolbar -> IDEAction+doGrep :: Toolbar -> PackageAction doGrep fb = do- ideR <- ask+ package <- ask+ ideR <- lift $ ask entry <- liftIO $ getFindEntry fb search <- liftIO $ entryGetText (castToEntry entry) entireWord <- liftIO $ getEntireWord fb@@ -400,11 +401,11 @@ wrapAround <- liftIO $ getWrapAround fb regex <- liftIO $ getRegex fb let (regexString, _) = regexStringAndMatchIndex entireWord regex search- mbPD <- getPackageDescriptionAndPath- case mbPD of+ mbPD <- lift getPackageDescriptionAndPath+ lift $ case mbPD of Nothing -> ideMessage Normal "No package description" Just (pd,cabalPath) -> do- let srcPaths = nub $ concatMap hsSourceDirs $ allBuildInfo pd+ let srcPaths = ipdSrcDirs package let dir = dropFileName (cabalPath) liftIO $ forkIO $ do (output, pid) <- runTool "grep" ((if caseSensitive then [] else ["-i"])
src/IDE/ImportTool.hs view
@@ -13,10 +13,12 @@ ----------------------------------------------------------------------------- module IDE.ImportTool (- addAllImports+ resolveErrors , addOneImport , addImport+, addPackage , parseNotInScope+, parseHiddenModule ) where import IDE.Core.State@@ -24,10 +26,8 @@ import IDE.Metainfo.Provider (getPackageImportInfo, getIdentifierDescr) import Text.PrettyPrint (render)-import Distribution.Text (disp)+import Distribution.Text (simpleParse, display, disp) import IDE.Pane.SourceBuffer- (belongsToPackage, maybeActiveBuf, fileSave,- inActiveBufContext, selectSourceBuf) import Graphics.UI.Gtk import Text.ParserCombinators.Parsec.Language (haskellStyle) import Graphics.UI.Editor.MakeEditor@@ -39,8 +39,7 @@ import Text.ParserCombinators.Parsec hiding (parse) import qualified Text.ParserCombinators.Parsec as Parsec (parse) import Graphics.UI.Editor.Simple (staticListEditor)-import Control.Monad (when)-import Distribution.Text (display)+import Control.Monad (forM, when) import Data.List (sort, nub, nubBy) import IDE.Utils.ServerConnection import Text.PrinterParser (prettyPrint)@@ -49,25 +48,32 @@ import qualified Text.ParserCombinators.Parsec.Token as P (operator, dot, identifier, symbol, lexeme, whiteSpace, makeTokenParser)-import Graphics.UI.Gtk.Gdk.Events (Event(..)) import Control.Monad.Trans (liftIO)---+import Distribution.PackageDescription.Parse+ (writePackageDescription, readPackageDescription)+import Distribution.Verbosity (normal)+import IDE.Pane.PackageEditor (hasConfigs)+import Distribution.Package+import Distribution.Version (VersionRange(..))+import Distribution.PackageDescription (buildDepends)+import Distribution.PackageDescription.Configuration+ (flattenPackageDescription) -- | Add all imports which gave error messages ...-addAllImports :: IDEAction-addAllImports = do+resolveErrors :: IDEAction+resolveErrors = do prefs' <- readIDE prefs let buildInBackground = backgroundBuild prefs' when buildInBackground $ modifyIDE_ (\ide -> ide{prefs = prefs'{backgroundBuild = False}}) errors <- readIDE errorRefs- addAll buildInBackground- [ y | (x,y) <-+ addPackageResults <- forM errors addPackage+ let notInScopes = [ y | (x,y) <- nubBy (\ (p1,_) (p2,_) -> p1 == p2) $ [(x,y) | (x,y) <- [((parseNotInScope . refDescription) e, e) | e <- errors]],- isJust x] (True,[])+ isJust x]+ when (not (or addPackageResults) && null notInScopes) $ ideMessage Normal $ "No errors that can be auto resolved"+ addAll buildInBackground notInScopes (True,[]) where addAll :: Bool -> [LogRef] -> (Bool,[Descr]) -> IDEM () addAll bib (errorSpec:rest) (True,descrList) = addImport errorSpec descrList (addAll bib rest)@@ -86,8 +92,7 @@ Nothing -> do ideMessage Normal $ "No error selected" return ()- Just ref -> do- addImport ref [] (\ _ -> return ())+ Just ref -> addImport ref [] (\ _ -> return ()) -- | Add one missing import -- Returns a boolean, if the process should be stopped in case of multiple addition@@ -122,6 +127,23 @@ else addImport' nis (logRefFullFilePath error) descr descrList continuation +addPackage :: LogRef -> IDEM Bool+addPackage error = do+ case parseHiddenModule (refDescription error) of+ Nothing -> return False+ Just (HiddenModuleResult mod pack) -> do+ let idePackage = logRefPackage error+ package <- liftIO $ readPackageDescription normal (ipdCabalFile $ idePackage)+ if hasConfigs package+ then return False+ else do+ let flat = flattenPackageDescription package+ ideMessage Normal $ "addPackage " ++ (display $ pkgName pack)+ liftIO $ writePackageDescription (ipdCabalFile $ idePackage)+ flat { buildDepends =+ Dependency (pkgName pack) AnyVersion : buildDepends flat}+ return True+ getScopeForActiveBuffer :: IDEM (Maybe (GenScope, GenScope)) getScopeForActiveBuffer = do mbActiveBuf <- maybeActiveBuf@@ -320,28 +342,18 @@ dia <- dialogNew windowSetTransientFor dia parentWindow upper <- dialogGetUpper dia- dialogAddButton dia "Ok" ResponseOk+ okButton <- dialogAddButton dia "Ok" ResponseOk dialogAddButton dia "Cancel" ResponseCancel (widget,inj,ext,_) <- buildEditor (moduleFields selectionList qualId) realSelectionString boxPackStart upper widget PackGrow 7 dialogSetDefaultResponse dia ResponseOk --does not work for the tree view widgetShowAll dia rw <- getRealWidget widget--- case rw of--- Nothing -> return ()--- Just r -> do--- r `onKeyPress` \ event -> do--- case event of--- Key { eventKeyName = name} ->--- case name of--- "Return" -> do--- dialogResponse dia ResponseOk--- return True--- _ -> return False--- _ -> return False--- return ()+ set okButton [widgetCanDefault := True]+ widgetGrabDefault okButton resp <- dialogRun dia value <- ext ([])+ widgetHide dia widgetDestroy dia --find case (resp,value) of@@ -351,3 +363,37 @@ Just pm -> (render . disp . modu) pm == v) list))) _ -> return Nothing +--testString = " Could not find module `Graphics.UI.Gtk':\n"+-- ++ " It is a member of the hidden package `gtk-0.11.0'.\n"+-- ++ " Perhaps you need to add `gtk' to the build-depends in your .cabal file.\n"+-- ++ " Use -v to see a list of the files searched for."+--+--test = parseHiddenModule testString == Just (HiddenModuleResult {hiddenModule = "Graphics.UI.Gtk", missingPackage = PackageIdentifier {pkgName = PackageName "gtk", pkgVersion = Version {versionBranch = [0,11,0], versionTags = []}}})++data HiddenModuleResult = HiddenModuleResult {+ hiddenModule :: String+ , missingPackage :: PackageId}+ deriving (Eq, Show)++parseHiddenModule :: String -> (Maybe HiddenModuleResult)+parseHiddenModule str =+ case Parsec.parse hiddenModuleParser "" str of+ Left e -> Nothing+ Right (mod, pack) ->+ case simpleParse pack of+ Just p -> Just $ HiddenModuleResult mod p+ Nothing -> Nothing++hiddenModuleParser :: CharParser () (String, String)+hiddenModuleParser = do+ whiteSpace+ symbol "Could not find module `"+ mod <- many (noneOf "'")+ symbol "':\n"+ whiteSpace+ symbol "It is a member of the hidden package `"+ pack <- many (noneOf "'")+ symbol "'.\n"+ many anyChar+ return (mod, pack)+ <?> "hiddenModuleParser"
src/IDE/Keymap.hs view
@@ -7,7 +7,7 @@ Keymap(..) ) where -import Graphics.UI.Gtk+import Graphics.UI.Gtk (keyvalFromName, KeyVal) import Graphics.UI.Gtk.Gdk.Events(Modifier(..)) import qualified Data.Map as Map import Text.ParserCombinators.Parsec
src/IDE/Leksah.hs view
@@ -1,8 +1,7 @@--{-# OPTIONS_GHC -XScopedTypeVariables #-}+{-# LANGUAGE CPP, ScopedTypeVariables #-} ----------------------------------------------------------------------------- ----- Module : Main+-- Module : IDE.Leksah -- Copyright : (c) Juergen Nicklisch-Franken, Hamish Mackenzie -- License : GNU-GPL --@@ -15,8 +14,8 @@ -- --------------------------------------------------------------------------------- -module Main (- main+module IDE.Leksah (+ leksah ) where import Graphics.UI.Gtk@@ -30,13 +29,14 @@ import Data.Version import Prelude hiding(catch) -#if defined(darwin_HOST_OS)-import IDE.OSX-#endif+import qualified IDE.OSX as OSX+import qualified IDE.YiConfig as Yi -#ifdef YI-import qualified Yi.UI.Pango.Control as Yi-import IDE.YiConfig+#ifdef LEKSAH_WITH_YI_DYRE+import System.Directory (getAppUserDataDirectory)+import System.FilePath ((</>))+import Control.Applicative ((<$>))+import qualified Config.Dyre as Dyre #endif import Paths_leksah@@ -54,9 +54,9 @@ import IDE.Find import Graphics.UI.Editor.Composite (filesEditor, maybeEditor) import Graphics.UI.Editor.Simple- (enumEditor, intEditor, stringEditor, boolEditor)+ (enumEditor, stringEditor) import IDE.Metainfo.Provider (initInfo)-import IDE.Workspaces (backgroundMake)+import IDE.Workspaces (workspaceOpenThis, backgroundMake) import IDE.Utils.GUIUtils import Network (withSocketsDo) import Control.Exception@@ -64,59 +64,112 @@ import qualified IDE.StrippedPrefs as SP import IDE.Utils.Tool (runTool,toolline) import IDE.System.Process(waitForProcess)-#if defined(mingw32_HOST_OS) || defined(__MINGW32__)-#else-import qualified System.Posix as P-#endif import System.Log import System.Log.Logger(updateGlobalLogger,rootLoggerName,setLevel) import Data.List (stripPrefix)+import System.Directory (doesFileExist)+import System.FilePath (dropExtension, splitExtension, (</>)) -- -------------------------------------------------------------------- -- Command line options -- -data Flag = VersionF | SessionN String | Help | Verbosity String+data Flag = VersionF | SessionN String | EmptySession | DefaultSession | Help | Verbosity String deriving (Show,Eq) options :: [OptDescr Flag]-options = [Option ['v'] ["version"] (NoArg VersionF)- "Show the version number of ide"+options = [Option ['e'] ["emptySession"] (NoArg EmptySession)+ "Start with empty session"+ , Option ['d'] ["defaultSession"] (NoArg DefaultSession)+ "Start with default session (can be used together with a source file)" , Option ['l'] ["loadSession"] (ReqArg SessionN "NAME") "Load session"+ , Option ['h'] ["help"] (NoArg Help) "Display command line options"+ , Option ['v'] ["version"] (NoArg VersionF)+ "Show the version number of ide"+ , Option ['e'] ["verbosity"] (ReqArg Verbosity "Verbosity")- "One of DEBUG, INFO, NOTICE, WARNING, ERROR, CRITICAL, ALERT, EMERGENCY"]+ "One of DEBUG, INFO, NOTICE, WARNING, ERROR, CRITICAL, ALERT, EMERGENCY"] -header = "Usage: leksah [OPTION...] files..." +header = "Usage: leksah [OPTION...] [file(.lkshs|.lkshw|.hs|.lhs)]"+ ideOpts :: [String] -> IO ([Flag], [String]) ideOpts argv = case getOpt Permute options argv of (o,n,[] ) -> return (o,n) (_,_,errs) -> ioError $ userError $ concat errs ++ usageInfo header options - -- --------------------------------------------------------------------- -- | Main function -- -main = withSocketsDo $ handleExceptions $ do-#if defined(mingw32_HOST_OS) || defined(__MINGW32__)+#ifdef LEKSAH_WITH_YI_DYRE+leksahDriver = Dyre.wrapMain Dyre.defaultParams+ { Dyre.projectName = "yi"+ , Dyre.realMain = \(config, mbError) -> do+ case mbError of+ Just error -> putStrLn $ "Error in yi configuration file : " ++ error+ Nothing -> return ()+ realMain config+ , Dyre.showError = \(config, _) error -> (config, Just error)+ , Dyre.configDir = Just . getAppUserDataDirectory $ "yi"+ , Dyre.cacheDir = Just $ ((</> "leksah") <$> (getAppUserDataDirectory "cache"))+ , Dyre.hidePackages = ["mtl"]+ , Dyre.ghcOpts = ["-DLEKSAH"]+ }++leksah yiConfig = leksahDriver (yiConfig, Nothing) #else- P.getProcessID >>= P.createProcessGroup+leksah = realMain #endif++realMain yiConfig = do+ withSocketsDo $ handleExceptions $ do+ dataDir <- getDataDir args <- getArgs - (o,_) <- ideOpts args- isFirstStart <- liftM not hasConfigDir+ (o,files) <- ideOpts args+ isFirstStart <- liftM not $ hasSavedConfigFile standardPreferencesFilename let sessions = filter (\x -> case x of SessionN _ -> True _ -> False) o- let sessionFilename = if not (null sessions)- then (head $ map (\ (SessionN x) -> x) sessions) ++ leksahSessionFileExtension- else standardSessionFilename++ let sessionFPs = filter (\f -> snd (splitExtension f) == leksahSessionFileExtension) files+ let workspaceFPs = filter (\f -> snd (splitExtension f) == leksahWorkspaceFileExtension) files+ let sourceFPs = filter (\f -> let (_,s) = splitExtension f+ in s == ".hs" || s == ".lhs" || s == ".chs") files+ let mbWorkspaceFP'= case workspaceFPs of+ [] -> Nothing+ w:_ -> Just w+ (mbWSessionFP, mbWorkspaceFP) <-+ case mbWorkspaceFP' of+ Nothing -> return (Nothing,Nothing)+ Just fp -> let spath = dropExtension fp ++ leksahSessionFileExtension+ in do+ exists <- liftIO $ doesFileExist spath+ if exists+ then return (Just spath,Nothing)+ else return (Nothing,Just fp)+ let ssession = if not (null sessions)+ then (head $ map (\ (SessionN x) -> x) sessions) +++ leksahSessionFileExtension+ else if null sourceFPs+ then standardSessionFilename+ else emptySessionFilename++ sessionFP <- if elem EmptySession o+ then getConfigFilePathForLoad+ emptySessionFilename Nothing dataDir+ else if elem DefaultSession o+ then getConfigFilePathForLoad+ standardSessionFilename Nothing dataDir+ else case mbWSessionFP of+ Just fp -> return fp+ Nothing -> getConfigFilePathForLoad+ ssession Nothing dataDir let verbosity' = catMaybes $ map (\x -> case x of Verbosity s -> Just s@@ -129,11 +182,11 @@ (sysMessage Normal $ "Leksah the Haskell IDE, version " ++ showVersion version) when (elem Help o) (sysMessage Normal $ "Leksah the Haskell IDE " ++ usageInfo header options)- dataDir <- getDataDir+ prefsPath <- getConfigFilePathForLoad standardPreferencesFilename Nothing dataDir prefs <- readPrefs prefsPath when (not (elem VersionF o) && not (elem Help o))- (startGUI sessionFilename prefs isFirstStart)+ (startGUI yiConfig sessionFP mbWorkspaceFP sourceFPs prefs isFirstStart) handleExceptions inner = catch inner (\(exception :: SomeException) -> do@@ -144,36 +197,44 @@ -- --------------------------------------------------------------------- -- | Start the GUI -startGUI :: String -> Prefs -> Bool -> IO ()-startGUI sessionFilename iprefs isFirstStart = do-#ifdef YI- Yi.startControl yiVimConfig $ do- yiControl <- Yi.getControl- Yi.controlIO $ do-#endif+startGUI :: Yi.Config -> FilePath -> Maybe FilePath -> [FilePath] -> Prefs -> Bool -> IO ()+startGUI yiConfig sessionFP mbWorkspaceFP sourceFPs iprefs isFirstStart = do+ Yi.start yiConfig $ \yiControl -> do st <- unsafeInitGUIForThreadedRTS when rtsSupportsBoundThreads (sysMessage Normal "Linked with -threaded") timeoutAddFull (yield >> return True) priorityDefaultIdle 100 -- maybe switch back to priorityHigh/??? mapM_ (sysMessage Normal) st initGtkRc+ dataDir <- getDataDir+ mbStartupPrefs <- if not isFirstStart+ then return $ Just iprefs+ else do+ firstStartOK <- firstStart iprefs+ if not firstStartOK+ then return Nothing+ else do+ prefsPath <- getConfigFilePathForLoad standardPreferencesFilename Nothing dataDir+ prefs <- readPrefs prefsPath+ return $ Just prefs+ case mbStartupPrefs of+ Nothing -> return ()+ Just startupPrefs -> startMainWindow yiControl sessionFP mbWorkspaceFP sourceFPs+ startupPrefs isFirstStart++startMainWindow :: Yi.Control -> FilePath -> Maybe FilePath -> [FilePath] ->+ Prefs -> Bool -> IO ()+startMainWindow yiControl sessionFP mbWorkspaceFP sourceFPs startupPrefs isFirstStart = do+ osxApp <- OSX.applicationNew uiManager <- uiManagerNew newIcons dataDir <- getDataDir- startupPrefs <- if not isFirstStart- then return iprefs- else do- firstStart iprefs- prefsPath <- getConfigFilePathForLoad standardPreferencesFilename Nothing dataDir- prefs <- readPrefs prefsPath- return prefs candyPath <- getConfigFilePathForLoad (case sourceCandy startupPrefs of- Nothing -> standardCandyFilename- Just name -> name ++ leksahCandyFileExtension) Nothing dataDir+ (_,name) -> name ++ leksahCandyFileExtension) Nothing dataDir candySt <- parseCandy candyPath -- keystrokes- keysPath <- getConfigFilePathForLoad (keymapName iprefs ++ leksahKeymapFileExtension) Nothing dataDir+ keysPath <- getConfigFilePathForLoad (keymapName startupPrefs ++ leksahKeymapFileExtension) Nothing dataDir keyMap <- parseKeymap keysPath let accelActions = setKeymap (keyMap :: KeymapI) mkActions specialKeys <- buildSpecialKeys keyMap accelActions@@ -215,11 +276,9 @@ , recentFiles = [] , recentWorkspaces = [] , runningTool = Nothing- , ghciState = Nothing- , completion = Nothing-#ifdef YI+ , debugState = Nothing+ , completion = ((750,400),Nothing) , yiControl = yiControl-#endif , server = Nothing } ideR <- newIORef ide@@ -231,25 +290,22 @@ win `onDelete` (\ _ -> do reflectIDE quit ideR; return True) reflectIDE (instrumentWindow win startupPrefs (castToWidget nb)) ideR reflectIDE (do- setCandyState (isJust (sourceCandy startupPrefs))+ setCandyState (fst (sourceCandy startupPrefs)) setBackgroundBuildToggled (backgroundBuild startupPrefs) setBackgroundLinkToggled (backgroundLink startupPrefs)) ideR let (x,y) = defaultSize startupPrefs windowSetDefaultSize win x y- sessionPath <- getConfigFilePathForLoad sessionFilename Nothing dataDir (tbv,fbv) <- reflectIDE (do- registerEvents- pair <- recoverSession sessionPath+ registerLeksahEvents+ pair <- recoverSession sessionFP+ workspaceOpenThis False mbWorkspaceFP+ mapM fileOpenThis sourceFPs wins <- getWindows mapM_ instrumentSecWindow (tail wins) return pair ) ideR widgetShowAll win -#if defined(darwin_HOST_OS)- updateMenu uiManager-#endif- reflectIDE (do triggerEventIDE UpdateRecent if tbv@@ -257,8 +313,11 @@ else hideToolbar if fbv then showFindbar- else hideFindbar) ideR+ else hideFindbar+ OSX.updateMenu osxApp uiManager) ideR + OSX.applicationReady osxApp+ when isFirstStart $ do welcomePath <- getConfigFilePathForLoad "welcome.txt" Nothing dataDir reflectIDE (fileOpenThis welcomePath) ideR@@ -281,53 +340,48 @@ (\b a -> a{sourceDirectories = b}) (filesEditor Nothing FileChooserActionSelectFolder "Select folders") , mkField- (paraName <<<- ParaName "Maybe a directory for unpacking cabal packages" $ emptyParams)+ (paraName <<<- ParaName "Unpack source for cabal packages to" $ emptyParams) unpackDirectory (\b a -> a{unpackDirectory = b})- (maybeEditor (stringEditor (\ _ -> True),emptyParams) True "")+ (maybeEditor (stringEditor (const True) True,emptyParams) True "") , mkField- (paraName <<<- ParaName "An URL to load prebuild metadata" $ emptyParams)+ (paraName <<<- ParaName "URL from which to download prebuilt metadata" $ emptyParams) retrieveURL (\b a -> a{retrieveURL = b})- (stringEditor (\ _ -> True))+ (stringEditor (\ _ -> True) True) , mkField- (paraName <<<- ParaName "A strategy for downloading prebuild metadata" $ emptyParams)+ (paraName <<<- ParaName "Strategy for downloading prebuilt metadata" $ emptyParams) retrieveStrategy (\b a -> a{retrieveStrategy = b})- (enumEditor ["Retrieve then build","Build then retrieve","Never retrieve"])- , mkField- (paraName <<<- ParaName "Port number for server connection" $ emptyParams)- serverPort- (\b a -> a{serverPort = b})- (intEditor (1.0, 65535.0, 1.0))- , mkField- (paraName <<<- ParaName "End the server with last connection" $ emptyParams)- endWithLastConn- (\b a -> a{endWithLastConn = b})- boolEditor]+ (enumEditor ["Try to download and then build locally if that fails","Try to build locally and then download if that fails","Never download (just try to build locally)"])] ----- | Called when leksah ist first called (the .leksah-xx directory does not exist)+-- | Called when leksah is first called (the .leksah-xx directory does not exist) ---firstStart :: Prefs -> IO ()+firstStart :: Prefs -> IO Bool firstStart prefs = do dataDir <- getDataDir prefsPath <- getConfigFilePathForLoad standardPreferencesFilename Nothing dataDir prefs <- readPrefs prefsPath configDir <- getConfigDir dialog <- dialogNew+ setLeksahIcon dialog+ set dialog [+ windowTitle := "Welcome to Leksah, the Haskell IDE",+ windowWindowPosition := WinPosCenter] dialogAddButton dialog "gtk-ok" ResponseOk dialogAddButton dialog "gtk-cancel" ResponseCancel vb <- dialogGetUpper dialog- label <- labelNew (Just ("Welcome to Leksah, the Haskell IDE.\n" ++- "At the first start, Leksah will collect and download metadata about your installed haskell packages.\n" ++- "You can add folders under which you have sources for Haskell packages not available from Hackage.\n" ++- "If you are not shure what to do, just keep the defaults \n" ++- "This process may take a long time, so be patient."))+ label <- labelNew (Just (+ "Before you start using Leksah it will collect and download metadata about your installed Haskell packages.\n" +++ "You can add folders under which you have sources for Haskell packages not available from Hackage.")) (widget, setInj, getExt,notifier) <- buildEditor (fDescription configDir) prefs- boxPackStart vb label PackGrow 7- boxPackStart vb widget PackGrow 7- widgetSetSizeRequest dialog 800 640+ boxPackStart vb label PackNatural 7+ sw <- scrolledWindowNew Nothing Nothing+ scrolledWindowAddWithViewport sw widget+ scrolledWindowSetPolicy sw PolicyNever PolicyAutomatic+ boxPackStart vb sw PackGrow 7+ windowSetDefaultSize dialog 800 630 widgetShowAll dialog response <- dialogRun dialog widgetHide dialog@@ -338,7 +392,7 @@ case mbNewPrefs of Nothing -> do sysMessage Normal "No dialog results"- return ()+ return False Just newPrefs -> do fp <- getConfigFilePathForSave standardPreferencesFilename writePrefs fp newPrefs@@ -351,10 +405,25 @@ SP.serverPort = serverPort newPrefs, SP.endWithLastConn = endWithLastConn newPrefs}) firstBuild newPrefs- _ -> widgetDestroy dialog+ return True+ _ -> do+ widgetDestroy dialog+ return False +setLeksahIcon :: (WindowClass self) => self -> IO ()+setLeksahIcon window = do+ dataDir <- getDataDir+ let iconPath = dataDir </> "pics" </> "leksah.png"+ iconExists <- doesFileExist iconPath+ when iconExists $+ windowSetIconFromFile window iconPath+ firstBuild newPrefs = do dialog <- dialogNew+ setLeksahIcon dialog+ set dialog [+ windowTitle := "Leksah: Updating Metadata",+ windowWindowPosition := WinPosCenter] vb <- dialogGetUpper dialog progressBar <- progressBarNew progressBarSetText progressBar "Please wait while Leksah collects information about Haskell packages on your system"
src/IDE/LogRef.hs view
@@ -1,4 +1,4 @@-{-# OPTIONS_GHC -XScopedTypeVariables #-}+{-# LANGUAGE CPP, ScopedTypeVariables #-} ----------------------------------------------------------------------------- -- -- Module : IDE.LogRef@@ -50,11 +50,11 @@ import IDE.Pane.Log import IDE.Utils.Tool import System.FilePath (equalFilePath)-import System.Directory (canonicalizePath) import Data.List (stripPrefix, elemIndex, isPrefixOf) import Data.Maybe (catMaybes) import System.Exit (ExitCode(..)) import System.Log.Logger (debugM)+import IDE.Utils.FileUtils(myCanonicalizePath) showSourceSpan :: LogRef -> String showSourceSpan = displaySrcSpan . logRefSrcSpan@@ -79,7 +79,8 @@ allBufs <- allBuffers forM_ [0 .. ((length logRefs)-1)] (\index -> do let ref = logRefs !! index- fpc <- liftIO $ canonicalizePath $ logRefFullFilePath ref+ fp = logRefFullFilePath ref+ fpc <- liftIO $ myCanonicalizePath fp forM_ (filter (\buf -> case (fileName buf) of Just fn -> equalFilePath fpc fn Nothing -> False) allBufs) (f index ref))@@ -244,6 +245,12 @@ setCurrentContext (Just new) selectRef $ Just new +#if MIN_VERSION_ghc(7,0,1)+fixColumn c = max 0 (c - 1)+#else+fixColumn = id+#endif+ srcSpanParser :: CharParser () SrcSpan srcSpanParser = try (do filePath <- many (noneOf ":")@@ -259,7 +266,7 @@ char ',' endCol <- int char ')'- return $ SrcSpan filePath beginLine beginCol endLine endCol)+ return $ SrcSpan filePath beginLine (fixColumn beginCol) endLine (fixColumn endCol)) <|> try (do filePath <- many (noneOf ":") char ':'@@ -268,14 +275,14 @@ beginCol <- int char '-' endCol <- int- return $ SrcSpan filePath line beginCol line endCol)+ return $ SrcSpan filePath line (fixColumn beginCol) line (fixColumn endCol)) <|> try (do filePath <- many (noneOf ":") char ':' line <- int char ':' col <- int- return $ SrcSpan filePath line col line col)+ return $ SrcSpan filePath line (fixColumn col) line (fixColumn col)) <?> "srcLocParser" data BuildError = BuildLine@@ -294,6 +301,7 @@ many (anyChar) return BuildLine) <|> try (do+ whiteSpace span <- srcSpanParser char ':' whiteSpace@@ -387,8 +395,8 @@ logOutputLines defaultLineLogger output return () -logOutputForBuild :: FilePath -> Bool -> [ToolOutput] -> IDEAction-logOutputForBuild rootPath backgroundBuild output = do+logOutputForBuild :: IDEPackage -> Bool -> [ToolOutput] -> IDEAction+logOutputForBuild package backgroundBuild output = do ideRef <- ask log <- getLog unless backgroundBuild $ liftIO $ bringPaneToFront log@@ -428,7 +436,7 @@ sysMessage Normal (show e) readAndShow remainingOutput ideR log False errs (Right ne@(ErrorLine span refType str),_) ->- readAndShow remainingOutput ideR log True ((LogRef span rootPath str (lineNr,lineNr) refType):errs)+ readAndShow remainingOutput ideR log True ((LogRef span package str (lineNr,lineNr) refType):errs) (Right (OtherLine str1),(LogRef span rootPath str (l1,l2) refType):tl) -> if inError then readAndShow remainingOutput ideR log True ((LogRef span@@ -471,38 +479,38 @@ ++ show warnNum ++ " warnings -----\n") FrameTag return errs -logOutputForBreakpoints :: FilePath -> [ToolOutput] -> IDEAction-logOutputForBreakpoints rootPath output = do+logOutputForBreakpoints :: IDEPackage -> [ToolOutput] -> IDEAction+logOutputForBreakpoints package 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 rootPath line (logLineNumber, logLineNumber) BreakpointRef+ return $ Just $ LogRef span package line (logLineNumber, logLineNumber) BreakpointRef _ -> return Nothing _ -> do defaultLineLogger log out return Nothing) output setBreakpointList $ catMaybes breaks -logOutputForSetBreakpoint :: FilePath -> [ToolOutput] -> IDEAction-logOutputForSetBreakpoint rootPath output = do+logOutputForSetBreakpoint :: IDEPackage -> [ToolOutput] -> IDEAction+logOutputForSetBreakpoint package 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 rootPath line (logLineNumber, logLineNumber) BreakpointRef+ return $ Just $ LogRef span package line (logLineNumber, logLineNumber) BreakpointRef _ -> return Nothing _ -> do defaultLineLogger log out return Nothing) output addLogRefs $ catMaybes breaks -logOutputForContext :: FilePath -> (String -> [SrcSpan]) -> [ToolOutput] -> IDEAction-logOutputForContext rootPath getContexts output = do+logOutputForContext :: IDEPackage -> (String -> [SrcSpan]) -> [ToolOutput] -> IDEAction+logOutputForContext package getContexts output = do refs <- fmap catMaybes $ logOutputLines (\log out -> do case out of ToolOutput line -> do@@ -510,7 +518,7 @@ let contexts = getContexts line if null contexts then return Nothing- else return $ Just $ LogRef (last contexts) rootPath line (logLineNumber, logLineNumber) ContextRef+ else return $ Just $ LogRef (last contexts) package line (logLineNumber, logLineNumber) ContextRef _ -> do defaultLineLogger log out return Nothing) output@@ -518,8 +526,8 @@ addLogRefs [last refs] lastContext -logOutputForLiveContext :: FilePath -> [ToolOutput] -> IDEAction-logOutputForLiveContext rootPath = logOutputForContext rootPath getContexts+logOutputForLiveContext :: IDEPackage -> [ToolOutput] -> IDEAction+logOutputForLiveContext package = logOutputForContext package getContexts where getContexts [] = [] getContexts line@(x:xs) = case stripPrefix "Stopped at " line of@@ -528,8 +536,8 @@ _ -> getContexts xs _ -> getContexts xs -logOutputForHistoricContext :: FilePath -> [ToolOutput] -> IDEAction-logOutputForHistoricContext rootPath = logOutputForContext rootPath getContexts+logOutputForHistoricContext :: IDEPackage -> [ToolOutput] -> IDEAction+logOutputForHistoricContext package = logOutputForContext package getContexts where getContexts line = case stripPrefix "Logged breakpoint at " line of Just rest -> case parse srcSpanParser "" rest of
src/IDE/Metainfo/Provider.hs view
@@ -35,7 +35,8 @@ , getPackageImportInfo -- Scope for the import tool ) where -import System.IO+import System.IO (hClose, openBinaryFile, IOMode(..))+import System.IO.Strict (readFile) import qualified Data.Map as Map import Control.Monad import Control.Monad.Trans@@ -64,7 +65,7 @@ import IDE.Core.Serializable () import Data.Map (Map(..)) import Control.Exception (SomeException(..), catch)-import Prelude hiding(catch)+import Prelude hiding(catch, readFile) import IDE.Utils.ServerConnection(doServerCommand) trace a b = b@@ -81,7 +82,7 @@ prefs <- readIDE prefs if collectAtStart prefs then do- ideMessage Normal "Now updating sytem metadata ..."+ ideMessage Normal "Now updating system metadata ..." callCollector False True True $ \ _ -> do ideMessage Normal "Now loading metadata ..." loadSystemInfo@@ -383,7 +384,7 @@ file <- openBinaryFile filePath ReadMode trace ("now loading metadata for package " ++ packageIdentifierToString pid) return () bs <- BSL.hGetContents file- let (metadataVersion', packageInfo) = decodeSer bs+ let (metadataVersion'::Integer, packageInfo::PackageDescr) = decodeSer bs if metadataVersion /= metadataVersion' then do hClose file@@ -430,7 +431,7 @@ then catch (do file <- openBinaryFile filePath ReadMode bs <- BSL.hGetContents file- let (metadataVersion', moduleInfo) = decodeSer bs+ let (metadataVersion'::Integer, moduleInfo::ModuleDescr) = decodeSer bs if metadataVersion /= metadataVersion' then do hClose file
src/IDE/OSX.hs view
@@ -1,4 +1,3 @@-{-# LANGUAGE ForeignFunctionInterface #-} ----------------------------------------------------------------------------- -- -- Module : IDE.OSX@@ -15,48 +14,63 @@ --------------------------------------------------------------------------------- module IDE.OSX (- updateMenu+ applicationNew+, updateMenu+, applicationReady ) where import Graphics.UI.Gtk-import Foreign (nullPtr, withForeignPtr, Ptr(..))-import System.Glib (GObject(..))+import IDE.Core.State -foreign import ccall unsafe "ige_mac_menu_set_menu_bar" ige_mac_menu_set_menu_bar :: Ptr GObject -> IO ()-foreign import ccall unsafe "ige_mac_menu_set_quit_menu_item" ige_mac_menu_set_quit_menu_item :: Ptr GObject -> IO ()-foreign import ccall unsafe "ige_mac_menu_add_app_menu_group" ige_mac_menu_add_app_menu_group :: IO (Ptr GObject)-foreign import ccall unsafe "ige_mac_menu_add_app_menu_item" ige_mac_menu_add_app_menu_item :: Ptr GObject -> Ptr GObject -> Ptr GObject -> IO ()+#if defined(darwin_HOST_OS) -updateMenu :: UIManager -> IO ()-updateMenu uiManager = do- mbMenu <- uiManagerGetWidget uiManager "/ui/menubar"- case mbMenu of- Just menu -> do- widgetHide menu- let (GObject p) = toGObject menu- withForeignPtr p ige_mac_menu_set_menu_bar- Nothing -> return ()+import Control.Monad.Reader (liftIO)+import Control.Monad.Reader.Class (ask)+import Graphics.UI.Gtk.OSX+import IDE.Command (canQuit) - mbQuit <- uiManagerGetWidget uiManager "/ui/menubar/_File/_Quit"- case mbQuit of- Just quit -> do- let (GObject p) = toGObject quit- withForeignPtr p ige_mac_menu_set_quit_menu_item- Nothing -> return ()+updateMenu :: Application -> UIManager -> IDEM ()+updateMenu app uiManager = do+ ideR <- ask+ liftIO $ do+ mbMenu <- uiManagerGetWidget uiManager "/ui/menubar"+ case mbMenu of+ Just menu -> do+ widgetHide menu+ applicationSetMenuBar app (castToMenuShell menu)+ Nothing -> return () - mbAbout <- uiManagerGetWidget uiManager "/ui/menubar/_Help/_About"- case mbAbout of- Just about -> do- let (GObject p) = toGObject about- group <- ige_mac_menu_add_app_menu_group- withForeignPtr p (\ptr -> ige_mac_menu_add_app_menu_item group ptr nullPtr)- Nothing -> return ()+ mbQuit <- uiManagerGetWidget uiManager "/ui/menubar/_File/_Quit"+ case mbQuit of+ Just quit -> widgetHide quit+ Nothing -> return () - mbPrefs <- uiManagerGetWidget uiManager "/ui/menubar/_Configuration/Edit general Preferences"- case mbPrefs of- Just prefs -> do- let (GObject p) = toGObject prefs- group <- ige_mac_menu_add_app_menu_group- withForeignPtr p (\ptr -> ige_mac_menu_add_app_menu_item group ptr nullPtr)- Nothing -> return ()+ mbAbout <- uiManagerGetWidget uiManager "/ui/menubar/_Help/_About"+ case mbAbout of+ Just about -> do+ group <- applicationAddAppMenuGroup app+ applicationAddAppMenuItem app group (castToMenuItem about)+ Nothing -> return () + mbPrefs <- uiManagerGetWidget uiManager "/ui/menubar/_Configuration/Edit general Preferences"+ case mbPrefs of+ Just prefs -> do+ group <- applicationAddAppMenuGroup app+ applicationAddAppMenuItem app group (castToMenuItem prefs)+ Nothing -> return ()++ app `on` blockTermination $ reflectIDE (fmap not canQuit) ideR++ applicationSetUseQuartsAccelerators app True++#else++data Application = Application+applicationNew :: IO Application+applicationNew = return Application+updateMenu :: Application -> UIManager -> IDEM ()+updateMenu _ _ = return ()+applicationReady :: Application -> IO ()+applicationReady _ = return ()++#endif
src/IDE/Package.hs view
@@ -23,16 +23,15 @@ , packageDoc , packageClean+, packageClean' , packageCopy , packageRun , activatePackage , deactivatePackage-, getActivePackage , packageInstall , packageInstall' , packageRegister-, packageUnregister , packageTest , packageSdist , packageOpenDoc@@ -40,6 +39,7 @@ , getPackageDescriptionAndPath , getModuleTemplate , addModuleToPackageDescr+, delModuleFromPackageDescr , backgroundBuildToggled , backgroundLinkToggled@@ -48,8 +48,12 @@ , printBindResultFlag , breakOnErrorFlag , breakOnExceptionFlag+ , printEvldWithShowFlag+, tryDebug+, tryDebug_ , executeDebugCommand+ , choosePackageFile , idePackageFromPath@@ -80,7 +84,7 @@ import IDE.LogRef import MyMissing (replace) import Distribution.ModuleName (ModuleName(..))-import Data.List (isInfixOf, nub, foldl')+import Data.List (isInfixOf, nub, foldl', delete) import qualified System.IO.UTF8 as UTF8 (readFile) import IDE.Utils.Tool (ToolOutput(..), runTool, newGhci, ToolState(..)) import qualified Data.Set as Set (fromList)@@ -113,9 +117,6 @@ selectActivePackage mbFilePath return () -getActivePackage :: IDEM (Maybe IDEPackage)-getActivePackage = readIDE activePack- selectActivePackage :: Maybe FilePath -> IDEM (Maybe IDEPackage) selectActivePackage mbFilePath' = do window <- getMainWindow@@ -155,28 +156,30 @@ triggerEventIDE (StatusbarChanged [CompartmentPackage txt]) return () -packageConfig :: IDEAction+packageConfig :: PackageAction packageConfig = do- mbPackage <- getActivePackage- case mbPackage of- Nothing -> return ()- Just package -> packageConfig' package (\ _ -> return ())+ package <- ask+ lift $ packageConfig' package (\ _ -> return ()) packageConfig' :: IDEPackage -> (Bool -> IDEAction) -> IDEAction packageConfig' package continuation = do let dir = dropFileName (ipdCabalFile package)- runExternalTool "Configuring" "runhaskell" (["Setup","configure"]+ runExternalTool "Configuring" "cabal" (["configure"] ++ (ipdConfigFlags package)) (Just dir) $ \output -> do logOutput output mbPack <- idePackageFromPath (ipdCabalFile package) case mbPack of Just pack -> do changeWorkspacePackage pack- modifyIDE_ (\ide -> ide{activePack = Just pack, bufferProjCache = Map.empty})+ modifyIDE_ (\ide -> ide{bufferProjCache = Map.empty})+ mbActivePack <- readIDE activePack+ case mbActivePack of+ Just activePack | ipdCabalFile package == ipdCabalFile activePack ->+ modifyIDE_ (\ide -> ide{activePack = Just pack})+ _ -> return () triggerEventIDE UpdateWorkspaceInfo triggerEventIDE (WorkspaceChanged False True)- errs <- readIDE errorRefs- continuation (last output == ToolExit ExitSuccess && not (any isError errs))+ continuation (last output == ToolExit ExitSuccess) return () Nothing -> do ideMessage Normal "Can't read package file"@@ -189,33 +192,30 @@ case oldWorkspace of Nothing -> return () Just ws ->- let ap = if isJust (wsActivePack ws) && ipdCabalFile (fromJust $ wsActivePack ws) == file- then Just ideP- else wsActivePack ws- ps = map exchange (wsPackages ws)- in modifyIDE_ (\ide -> ide{workspace = Just ws {wsPackages = ps, wsActivePack = ap}})+ let ps = map exchange (wsPackages ws)+ in modifyIDE_ (\ide -> ide{workspace = Just ws {wsPackages = ps}}) where exchange p | ipdCabalFile p == file = ideP- | otherwise = p+ | otherwise = p runCabalBuild :: Bool -> IDEPackage -> Bool -> (Bool -> IDEAction) -> IDEAction runCabalBuild backgroundBuild package shallConfigure continuation = do prefs <- readIDE prefs let dir = dropFileName (ipdCabalFile package)- let args = (["Setup","build"] +++ let args = (["build"] ++ if ((not backgroundBuild) || (backgroundLink prefs)) then [] else ["--ghc-options=-c", "--with-ar=true", "--with-ld=true"] ++ ipdBuildFlags package)- runExternalTool "Building" "runhaskell" args (Just dir) $ \output -> do- logOutputForBuild dir backgroundBuild output+ runExternalTool "Building" "cabal" args (Just dir) $ \output -> do+ logOutputForBuild package backgroundBuild output errs <- readIDE errorRefs if shallConfigure && isConfigError output then packageConfig' package (\ b -> when b $ runCabalBuild backgroundBuild package False continuation) else do- continuation (last output == ToolExit ExitSuccess && not (any isError errs))+ continuation (last output == ToolExit ExitSuccess) return () isConfigError :: [ToolOutput] -> Bool@@ -227,11 +227,11 @@ str2 = "please re-configure" buildPackage :: Bool -> IDEPackage -> (Bool -> IDEAction) -> IDEAction-buildPackage backgroundBuild package continuation = catchIDE (do+buildPackage backgroundBuild package continuation = catchIDE (do ideR <- ask prefs <- readIDE prefs- maybeGhci <- readIDE ghciState- case maybeGhci of+ maybeDebug <- readIDE debugState+ case maybeDebug of Nothing -> do alreadyRunning <- isRunning if alreadyRunning@@ -243,150 +243,134 @@ return False) priorityDefaultIdle 1000 return () else runCabalBuild backgroundBuild package True continuation- Just ghci -> do+ Just debug@(_, ghci) -> do+ -- TODO check debug package matches active package ready <- liftIO $ isEmptyMVar (currentToolCommand ghci) when ready $ do let dir = dropFileName (ipdCabalFile package) when (saveAllBeforeBuild prefs) (do fileSaveAll belongsToWorkspace; return ())- executeDebugCommand ":reload" $ logOutputForBuild dir backgroundBuild+ runDebug (executeDebugCommand ":reload" (logOutputForBuild package backgroundBuild)) debug ) (\(e :: SomeException) -> sysMessage Normal (show e)) -packageDoc :: IDEAction-packageDoc = catchIDE (do- mbPackage <- getActivePackage- case mbPackage of- Nothing -> return ()- Just package -> let dir = dropFileName (ipdCabalFile package)- in runExternalTool "Documenting" "runhaskell" (["Setup","haddock"]- ++ (ipdHaddockFlags package)) (Just dir) logOutput)+packageDoc :: PackageAction+packageDoc = do+ package <- ask+ lift $ catchIDE (do+ let dir = dropFileName (ipdCabalFile package)+ runExternalTool "Documenting" "cabal" (["haddock"]+ ++ (ipdHaddockFlags package)) (Just dir) logOutput) (\(e :: SomeException) -> putStrLn (show e)) -packageClean :: Maybe IDEPackage -> IDEAction-packageClean Nothing = do- mbPackage <- getActivePackage- case mbPackage of- Nothing -> return ()- Just package -> packageClean' package-packageClean (Just package) = packageClean' package+packageClean :: PackageAction+packageClean = do+ package <- ask+ lift $ packageClean' package (\ _ -> return ()) -packageClean' :: IDEPackage -> IDEAction-packageClean' package =+packageClean' :: IDEPackage -> (Bool -> IDEAction) -> IDEAction+packageClean' package continuation = let dir = dropFileName (ipdCabalFile package)- in runExternalTool "Cleaning" "runhaskell" ["Setup","clean"] (Just dir) logOutput+ in runExternalTool "Cleaning" "cabal" ["clean"] (Just dir)+ (\ output -> do+ logOutput output+ continuation (last output == ToolExit ExitSuccess)) -packageCopy :: IDEAction-packageCopy = catchIDE (do- mbPackage <- getActivePackage+packageCopy :: PackageAction+packageCopy = do+ package <- ask+ lift $ catchIDE (do window <- getMainWindow mbDir <- liftIO $ chooseDir window "Select the target directory" Nothing case mbDir of Nothing -> return ()- Just fp ->- case mbPackage of- Nothing -> return ()- Just package -> let dir = dropFileName (ipdCabalFile package)- in runExternalTool "Copying" "runhaskell" (["Setup","copy"]- ++ ["--destdir=" ++ fp]) (Just dir) logOutput)+ Just fp -> do+ let dir = dropFileName (ipdCabalFile package)+ runExternalTool "Copying" "cabal" (["copy"]+ ++ ["--destdir=" ++ fp]) (Just dir) logOutput) (\(e :: SomeException) -> putStrLn (show e)) -packageRun :: IDEAction-packageRun = catchIDE (do+packageRun :: PackageAction+packageRun = do+ package <- ask+ lift $ catchIDE (do ideR <- ask- mbPackage <- getActivePackage- maybeGhci <- readIDE ghciState- case mbPackage of- Nothing -> return ()- Just package -> do- pd <- liftIO $ readPackageDescription normal (ipdCabalFile package) >>= return . flattenPackageDescription- case maybeGhci of- Nothing -> do- case executables pd of- (Executable name _ _):_ -> do- let path = "dist/build" </> name </> name- let dir = dropFileName (ipdCabalFile package)- runExternalTool ("Running " ++ name) path (ipdExeFlags package) (Just dir) 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 (ipdExeFlags package))) logOutput- otherwise -> do- sysMessage Normal "no executable in selected package"- return ())+ maybeDebug <- readIDE debugState+ pd <- liftIO $ readPackageDescription normal (ipdCabalFile package) >>= return . flattenPackageDescription+ case maybeDebug of+ Nothing -> do+ case executables pd of+ (Executable name _ _):_ -> do+ let path = "dist/build" </> name </> name+ let dir = dropFileName (ipdCabalFile package)+ runExternalTool ("Running " ++ name) path (ipdExeFlags package) (Just dir) logOutput+ otherwise -> do+ sysMessage Normal "no executable in selected package"+ return ()+ Just debug -> do+ -- TODO check debug package matches active package+ case executables pd of+ (Executable _ mainFilePath _):_ -> do+ runDebug (do+ executeDebugCommand (":module *" ++ (map (\c -> if c == '/' then '.' else c) (takeWhile (/= '.') mainFilePath))) logOutput+ executeDebugCommand (":main " ++ (unwords (ipdExeFlags package))) logOutput) debug+ otherwise -> do+ sysMessage Normal "no executable in selected package"+ return ()) (\(e :: SomeException) -> putStrLn (show e)) -packageInstall :: IDEAction+packageInstall :: PackageAction packageInstall = do- mbPackage <- getActivePackage- case mbPackage of- Nothing -> return ()- Just package -> packageInstall' package (\ _ -> return ())+ package <- ask+ lift $ packageInstall' package (\ _ -> return ()) packageInstall' :: IDEPackage -> (Bool -> IDEAction) -> IDEAction packageInstall' package continuation = catchIDE (do let dir = dropFileName (ipdCabalFile package)- runExternalTool "Installing" "runhaskell" (["Setup","install"]- ++ (ipdInstallFlags package)) (Just dir) (\ to -> logOutput to >> continuation True)) --TODO- (\(e :: SomeException) -> putStrLn (show e))--packageRegister :: IDEAction-packageRegister = catchIDE (do- mbPackage <- getActivePackage- case mbPackage of- Nothing -> return ()- Just package -> let dir = dropFileName (ipdCabalFile package)- in runExternalTool "Registering" "runhaskell" (["Setup","register"]- ++ (ipdRegisterFlags package)) (Just dir) logOutput)+ runExternalTool "Installing" "runhaskell" (["Setup", "install"]+ ++ (ipdInstallFlags package)) (Just dir) (\ output -> do+ logOutput output+ continuation (last output == ToolExit ExitSuccess))) (\(e :: SomeException) -> putStrLn (show e)) -packageUnregister :: IDEAction-packageUnregister = catchIDE (do- mbPackage <- getActivePackage- case mbPackage of- Nothing -> return ()- Just package -> let dir = dropFileName (ipdCabalFile package)- in runExternalTool "Unregistering" "runhaskell" (["Setup","unregister"]- ++ (ipdUnregisterFlags package)) (Just dir) logOutput)+packageRegister :: PackageAction+packageRegister = do+ package <- ask+ lift $ catchIDE (do+ let dir = dropFileName (ipdCabalFile package)+ runExternalTool "Registering" "cabal" (["register"]+ ++ (ipdRegisterFlags package)) (Just dir) logOutput) (\(e :: SomeException) -> putStrLn (show e)) -packageTest :: IDEAction-packageTest = catchIDE (do- mbPackage <- getActivePackage- case mbPackage of- Nothing -> return ()- Just package -> let dir = dropFileName (ipdCabalFile package)- in runExternalTool "Testing" "runhaskell" (["Setup","test"]) (Just dir) logOutput)+packageTest :: PackageAction+packageTest = do+ package <- ask+ lift $ catchIDE (do+ let dir = dropFileName (ipdCabalFile package)+ runExternalTool "Testing" "cabal" (["test"]) (Just dir) logOutput) (\(e :: SomeException) -> putStrLn (show e)) -packageSdist :: IDEAction-packageSdist = catchIDE (do- mbPackage <- getActivePackage- case mbPackage of- Nothing -> return ()- Just package -> let dir = dropFileName (ipdCabalFile package)- in runExternalTool "Source Dist" "runhaskell" (["Setup","sdist"]- ++ (ipdSdistFlags package)) (Just dir) logOutput)+packageSdist :: PackageAction+packageSdist = do+ package <- ask+ lift $ catchIDE (do+ let dir = dropFileName (ipdCabalFile package)+ runExternalTool "Source Dist" "cabal" (["sdist"]+ ++ (ipdSdistFlags package)) (Just dir) logOutput) (\(e :: SomeException) -> putStrLn (show e)) -packageOpenDoc :: IDEAction-packageOpenDoc = catchIDE (do- mbPackage <- getActivePackage- prefs <- readIDE prefs- case mbPackage of- Nothing -> return ()- Just package ->- let path = dropFileName (ipdCabalFile package)- </> "dist/doc/html"- </> display (pkgName (ipdPackageId package))- </> display (pkgName (ipdPackageId package))- </> "index.html"- dir = dropFileName (ipdCabalFile package)- in runExternalTool "Opening Documentation" (browser prefs) [path] (Just dir) logOutput)+packageOpenDoc :: PackageAction+packageOpenDoc = do+ package <- ask+ lift $ catchIDE (do+ prefs <- readIDE prefs+ let path = dropFileName (ipdCabalFile package)+ </> "dist/doc/html"+ </> display (pkgName (ipdPackageId package))+ </> display (pkgName (ipdPackageId package))+ </> "index.html"+ dir = dropFileName (ipdCabalFile package)+ runExternalTool "Opening Documentation" (browser prefs) [path] (Just dir) logOutput) (\(e :: SomeException) -> putStrLn (show e)) runExternalTool :: String -> FilePath -> [String] -> Maybe FilePath -> ([ToolOutput] -> IDEAction) -> IDEAction@@ -455,41 +439,76 @@ (\ (e :: SomeException) -> sysMessage Normal ("Couldn't read template file: " ++ show e) >> return "") -addModuleToPackageDescr :: ModuleName -> Bool -> IDEM ()+addModuleToPackageDescr :: ModuleName -> Bool -> PackageAction addModuleToPackageDescr moduleName isExposed = do- active <- readIDE activePack- case active of- Nothing -> do- ideMessage Normal "No active package"- return ()- Just p -> do- ideR <- ask- reifyIDE (\ideR -> catch (do- gpd <- readPackageDescription normal (ipdCabalFile p)- if hasConfigs gpd- then do- reflectIDE (ideMessage High- "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)- then pd{library = Just ((fromJust (library pd)){exposedModules =- moduleName : exposedModules (fromJust $ library pd)})}- else let npd1 = case library pd of- Nothing -> pd- Just lib -> pd{library = Just (lib{libBuildInfo =- addModToBuildInfo (libBuildInfo lib) moduleName})}- in npd1{executables = map- (\exe -> exe{buildInfo = addModToBuildInfo (buildInfo exe) moduleName})- (executables npd1)}- in writePackageDescription (ipdCabalFile p) npd)- (\(e :: SomeException) -> do- reflectIDE (ideMessage Normal ("Can't upade package " ++ show e)) ideR- return ()))+ p <- ask+ lift $ reifyIDE (\ideR -> catch (do+ gpd <- readPackageDescription normal (ipdCabalFile p)+ if hasConfigs gpd+ then do+ reflectIDE (ideMessage High+ "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)+ then pd{library = Just ((fromJust (library pd)){exposedModules =+ moduleName : exposedModules (fromJust $ library pd)})}+ else let npd1 = case library pd of+ Nothing -> pd+ Just lib -> pd{library = Just (lib{libBuildInfo =+ addModToBuildInfo (libBuildInfo lib) moduleName})}+ in npd1{executables = map+ (\exe -> exe{buildInfo = addModToBuildInfo (buildInfo exe) moduleName})+ (executables npd1)}+ in writePackageDescription (ipdCabalFile p) npd)+ (\(e :: SomeException) -> do+ reflectIDE (ideMessage Normal ("Can't upade package " ++ show e)) ideR+ return ())) where addModToBuildInfo :: BuildInfo -> ModuleName -> BuildInfo addModToBuildInfo bi mn = bi {otherModules = mn : otherModules bi} +--------------------------------------------------------------------------+delModuleFromPackageDescr :: ModuleName -> PackageAction+delModuleFromPackageDescr moduleName = do+ p <- ask+ lift $ reifyIDE (\ideR -> catch (do+ gpd <- readPackageDescription normal (ipdCabalFile p)+ if hasConfigs gpd+ then do+ reflectIDE (ideMessage High+ "Cabal file with configurations can't be automatically updated with the current version of Leksah") ideR+ else+ let pd = flattenPackageDescription gpd+ isExposedAndJust = isExposedModule pd moduleName+ npd = if isExposedAndJust+ then pd{library = Just ((fromJust (library pd)){exposedModules =+ delete moduleName (exposedModules (fromJust $ library pd))})}+ else let npd1 = case library pd of+ Nothing -> pd+ Just lib -> pd{library = Just (lib{libBuildInfo =+ delModFromBuildInfo (libBuildInfo lib) moduleName})}+ in npd1{executables = map+ (\exe -> exe{buildInfo = delModFromBuildInfo (buildInfo exe) moduleName})+ (executables npd1)}+ in writePackageDescription (ipdCabalFile p) npd)+ (\(e :: SomeException) -> do+ reflectIDE (ideMessage Normal ("Can't update package " ++ show e)) ideR+ return ()))+ where+ delModFromBuildInfo :: BuildInfo -> ModuleName -> BuildInfo+ delModFromBuildInfo bi mn = bi {otherModules = delete mn (otherModules bi)}+++isExposedModule :: PackageDescription -> ModuleName -> Bool+isExposedModule pd mn = do+ if isJust (library pd)+ then elem mn (exposedModules (fromJust $ library pd))+ else False++--------------------------------------------------------------------------++ backgroundBuildToggled :: IDEAction backgroundBuildToggled = do toggled <- getBackgroundBuildToggled@@ -526,72 +545,97 @@ : (breakOnErrorFlag $ breakOnError prefs) : [printBindResultFlag $ printBindResult prefs] -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- let dir = dropFileName (ipdCabalFile package)- ghci <- reifyIDE $ \ideR -> newGhci (ipdBuildFlags package) (interactiveFlags prefs')- $ \output -> reflectIDE (logOutputForBuild dir True output) ideR- modifyIDE_ (\ide -> ide {ghciState = Just ghci})- triggerEventIDE (Sensitivity [(SensitivityInterpreting, True)])- setDebugToggled True- -- Fork a thread to wait for the output from the process to close- liftIO $ forkIO $ do- readMVar (outputClosed ghci)- reflectIDE (do- setDebugToggled False- modifyIDE_ (\ide -> ide {ghciState = Nothing})- triggerEventIDE (Sensitivity [(SensitivityInterpreting, False)])- -- Kick of a build if one is not already due- modifiedPacks <- fileCheckAll belongsToPackage- let modified = not (null modifiedPacks)- prefs <- readIDE prefs- when ((not modified) && (backgroundBuild prefs)) $ do- -- So although none of the pakages are modified,- -- they may have been modified in ghci mode.- -- Lets build to make sure the binaries are up to date- mbPackage <- readIDE activePack- case mbPackage of- Just package -> runCabalBuild True package True (\ _ -> return ())- Nothing -> return ()) ideRef- return ()- _ -> do- sysMessage Normal "Debugger already running"- return ())- (\(e :: SomeException) -> putStrLn (show e))--executeDebugCommand :: String -> ([ToolOutput] -> IDEAction) -> IDEAction-executeDebugCommand command handler = do- maybeGhci <- readIDE ghciState- case maybeGhci of- Just ghci -> do- triggerEventIDE (StatusbarChanged [CompartmentState command, CompartmentBuild True])- reifyIDE $ \ideR -> do- executeGhciCommand ghci command $ \output ->+debugStart :: PackageAction+debugStart = do+ package <- ask+ lift $ catchIDE (do+ ideRef <- ask+ prefs' <- readIDE prefs+ maybeDebug <- readIDE debugState+ case maybeDebug of+ Nothing -> do+ ghci <- reifyIDE $ \ideR -> newGhci (ipdBuildFlags package) (interactiveFlags prefs')+ $ \output -> reflectIDE (logOutputForBuild package True output) ideR+ modifyIDE_ (\ide -> ide {debugState = Just (package, ghci)})+ triggerEventIDE (Sensitivity [(SensitivityInterpreting, True)])+ setDebugToggled True+ -- Fork a thread to wait for the output from the process to close+ liftIO $ forkIO $ do+ readMVar (outputClosed ghci) reflectIDE (do- handler output- triggerEventIDE (StatusbarChanged [CompartmentState "", CompartmentBuild False])- return ()- ) ideR+ setDebugToggled False+ modifyIDE_ (\ide -> ide {debugState = Nothing})+ triggerEventIDE (Sensitivity [(SensitivityInterpreting, False)])+ -- Kick of a build if one is not already due+ modifiedPacks <- fileCheckAll belongsToPackage+ let modified = not (null modifiedPacks)+ prefs <- readIDE prefs+ when ((not modified) && (backgroundBuild prefs)) $ do+ -- So although none of the pakages are modified,+ -- they may have been modified in ghci mode.+ -- Lets build to make sure the binaries are up to date+ mbPackage <- readIDE activePack+ case mbPackage of+ Just package -> runCabalBuild True package True (\ _ -> return ())+ Nothing -> return ()) ideRef+ return ()+ _ -> do+ sysMessage Normal "Debugger already running"+ return ())+ (\(e :: SomeException) -> putStrLn (show e))++tryDebug :: DebugM a -> PackageM (Maybe a)+tryDebug f = do+ maybeDebug <- lift $ readIDE debugState+ case maybeDebug of+ Just debug -> do+ -- TODO check debug package matches active package+ liftM Just $ lift $ runDebug f debug _ -> do- md <- liftIO $ messageDialogNew Nothing [] MessageQuestion ButtonsYesNo- "GHCi debugger is not running. Would you like to start it?"- resp <- liftIO $ dialogRun md- liftIO $ widgetHide md+ window <- lift $ getMainWindow+ resp <- liftIO $ do+ md <- messageDialogNew (Just window) [] MessageQuestion ButtonsCancel+ "GHCi debugger is not running."+ dialogAddButton md "_Start GHCi" (ResponseUser 1)+ dialogSetDefaultResponse md (ResponseUser 1)+ set md [ windowWindowPosition := WinPosCenterOnParent ]+ resp <- dialogRun md+ widgetDestroy md+ return resp case resp of- ResponseYes -> do+ ResponseUser 1 -> do debugStart- executeDebugCommand command handler- _ -> return ()+ maybeDebug <- lift $ readIDE debugState+ case maybeDebug of+ Just debug -> liftM Just $ lift $ runDebug f debug+ _ -> return Nothing+ _ -> return Nothing +tryDebug_ :: DebugM a -> PackageAction+tryDebug_ f = tryDebug f >> return ()++executeDebugCommand :: String -> ([ToolOutput] -> IDEAction) -> DebugAction+executeDebugCommand command handler = do+ (_, ghci) <- ask+ lift $ do+ triggerEventIDE (StatusbarChanged [CompartmentState command, CompartmentBuild True])+ reifyIDE $ \ideR -> do+ executeGhciCommand ghci command $ \output ->+ reflectIDE (do+ handler output+ triggerEventIDE (StatusbarChanged [CompartmentState "", CompartmentBuild False])+ return ()+ ) ideR++allBuildInfo' :: PackageDescription -> [BuildInfo]+#if MIN_VERSION_Cabal(1,10,0)+allBuildInfo' pkg_descr = [ libBuildInfo lib | Just lib <- [library pkg_descr] ]+ ++ [ buildInfo exe | exe <- executables pkg_descr ]+ ++ [ testBuildInfo tst | tst <- testSuites pkg_descr ]+#else+allBuildInfo' = allBuildInfo+#endif+ idePackageFromPath :: FilePath -> IDEM (Maybe IDEPackage) idePackageFromPath filePath = do mbPackageD <- reifyIDE (\ideR -> catch (do@@ -606,11 +650,31 @@ let modules = Set.fromList $ myLibModules packageD ++ myExeModules packageD let mainFiles = map modulePath (executables packageD) let files = Set.fromList $ extraSrcFiles packageD ++ map modulePath (executables packageD)- let ipdSrcDirs = nub $ concatMap hsSourceDirs (allBuildInfo packageD)- let exts = nub $ concatMap extensions (allBuildInfo packageD)- let packp = IDEPackage (package packageD) filePath (buildDepends packageD) modules-- mainFiles files ipdSrcDirs exts ["--user"] [] [] [] [] [] [] []+ let srcDirs = case (nub $ concatMap hsSourceDirs (allBuildInfo' packageD)) of+ [] -> [".","src"]+ l -> l+#if MIN_VERSION_Cabal(1,10,0)+ let exts = nub $ concatMap oldExtensions (allBuildInfo' packageD)+#else+ let exts = nub $ concatMap extensions (allBuildInfo' packageD)+#endif+ let packp = IDEPackage {+ ipdPackageId = package packageD,+ ipdCabalFile = filePath,+ ipdDepends = buildDepends packageD,+ ipdModules = modules,+ ipdMain = mainFiles,+ ipdExtraSrcs = files,+ ipdSrcDirs = srcDirs,+ ipdExtensions = exts,+ ipdConfigFlags = ["--user"],+ ipdBuildFlags = [],+ ipdHaddockFlags = [],+ ipdExeFlags = [],+ ipdInstallFlags = [],+ ipdRegisterFlags = [],+ ipdUnregisterFlags = [],+ ipdSdistFlags = []} let pfile = dropExtension filePath pack <- (do flagFileExists <- liftIO $ doesFileExist (pfile ++ leksahFlagFileExtension)
src/IDE/Pane/Errors.hs view
@@ -29,7 +29,9 @@ import Graphics.UI.Gtk.General.Enums (Click(..), MouseButton(..)) import Graphics.UI.Gtk.Gdk.Events (Event(..))-import IDE.ImportTool (addImport,parseNotInScope, addAllImports)+import IDE.ImportTool+ (addPackage, parseHiddenModule, addImport, parseNotInScope,+ resolveErrors) import Data.List (elemIndex) import IDE.LogRef (showSourceSpan) @@ -166,20 +168,28 @@ then do mbSel <- getSelectedError treeView store theMenu <- menuNew- item0 <- menuItemNewWithLabel "Add all imports"+ item0 <- menuItemNewWithLabel "Resolve Errors" item0 `onActivateLeaf` do- reflectIDE addAllImports ideR+ reflectIDE resolveErrors ideR menuShellAppend theMenu item0 case mbSel of- Just sel ->+ Just sel -> do 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 -> do+ return ()+ Just _ -> do+ item1 <- menuItemNewWithLabel "Add Import"+ item1 `onActivateLeaf` do+ reflectIDE (addImport sel [] (\ _ -> return ())) ideR+ menuShellAppend theMenu item1+ case parseHiddenModule (refDescription sel) of+ Nothing -> do+ return ()+ Just _ -> do+ item1 <- menuItemNewWithLabel "Add Package"+ item1 `onActivateLeaf` do+ reflectIDE (addPackage sel >> return ()) ideR+ menuShellAppend theMenu item1 Nothing -> return () menuPopup theMenu Nothing widgetShowAll theMenu
src/IDE/Pane/Info.hs view
@@ -19,6 +19,7 @@ , InfoState , setInfo , replayInfoHistory+, openDocu ) where import Graphics.UI.Gtk hiding (afterToggleOverwrite)@@ -26,10 +27,11 @@ import Control.Monad.Trans import Data.IORef import Data.Typeable+import Data.Char (isAlphaNum)+import Network.URI (escapeURIString) import IDE.Core.State import IDE.Pane.SourceBuffer-import IDE.Pane.References import IDE.Utils.GUIUtils (openBrowser,controlIsPressed) import Graphics.UI.Gtk.SourceView @@ -64,19 +66,6 @@ prefs <- readIDE prefs 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@@ -90,10 +79,13 @@ descriptionBuffer <- (get descriptionView textViewBuffer) >>= (return . castToSourceBuffer) lm <- sourceLanguageManagerNew mbLang <- sourceLanguageManagerGuessLanguage lm Nothing (Just "text/x-haskell")+#if MIN_VERSION_gtksourceview2(0,12,0)+ sourceBufferSetLanguage descriptionBuffer mbLang+#else case mbLang of Nothing -> return () Just lang -> do sourceBufferSetLanguage descriptionBuffer lang-+#endif -- 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@@ -102,13 +94,17 @@ widgetModifyFont descriptionView (Just font) case sourceStyle prefs of- Nothing -> return ()- Just str -> do+ (False,_) -> return ()+ (True,str) -> do styleManager <- sourceStyleSchemeManagerNew ids <- sourceStyleSchemeManagerGetSchemeIds styleManager when (elem str ids) $ do scheme <- sourceStyleSchemeManagerGetScheme styleManager str+#if MIN_VERSION_gtksourceview2(0,12,0)+ sourceBufferSetStyleScheme descriptionBuffer $ Just scheme+#else sourceBufferSetStyleScheme descriptionBuffer scheme+#endif sw <- scrolledWindowNew Nothing Nothing@@ -116,28 +112,17 @@ scrolledWindowSetPolicy sw PolicyAutomatic PolicyAutomatic boxPackStart ibox sw PackGrow 10- boxPackEnd ibox bb PackNatural 10 ++ --openType currentDescr' <- newIORef idDescr+#if MIN_VERSION_gtk(0,10,5)+ cid <- on descriptionView populatePopup (populatePopupMenu ideR currentDescr')+#else+ cid <- descriptionView `onPopulatePopup` (populatePopupMenu ideR currentDescr')+#endif let info = IDEInfo ibox currentDescr' descriptionView- definitionB `onClicked` (reflectIDE gotoSource ideR )- moduB `onClicked` (reflectIDE gotoModule' ideR )- usesB `onClicked` (reflectIDE referencedFrom' ideR )- searchB `onClicked` (do- mbDescr <- readIORef currentDescr'- case mbDescr of- Nothing -> return ()- Just descr -> reflectIDE (do- triggerEventIDE (SearchMeta (dscName descr))- i :: IDEInfo <- forceGetPane (Right "*Info")- displayPane i False- return ()) ideR )- docuB `onClicked` (do- mbDescr <- readIORef currentDescr'- case mbDescr of- Nothing -> return ()- Just descr -> reflectIDE (openBrowser $ docuSearchURL prefs ++ dscName descr) ideR) descriptionView `widgetAddEvents` [ButtonReleaseMask] id5 <- descriptionView `onButtonRelease` (\ e -> do@@ -149,13 +134,13 @@ triggerEventIDE (SelectInfo symbol) return ()) ideR) return False)- return (Just info,[])+ return (Just info,[ConnectC cid]) gotoSource :: IDEAction gotoSource = do mbInfo <- getInfoCont case mbInfo of- Nothing -> do ideMessage Normal "gotoSource:noDefition"+ Nothing -> do ideMessage Normal "gotoSource:noDefinition" return () Just info -> goToDefinition info >> return () @@ -166,12 +151,6 @@ Nothing -> return () Just info -> triggerEventIDE (SelectIdent info) >> return () -referencedFrom' :: IDEAction-referencedFrom' = do- mbInfo <- getInfoCont- case mbInfo of- Nothing -> return ()- Just info -> referencedFrom info >> return () setInfo :: Descr -> IDEAction setInfo identifierDescr = do@@ -205,5 +184,30 @@ case mbDescr of Nothing -> return () Just descr -> setInfo descr++openDocu :: IDEAction+openDocu = do+ mbDescr <- getInfoCont+ case mbDescr of+ Nothing -> return ()+ Just descr -> do+ prefs' <- readIDE prefs+ openBrowser $ docuSearchURL prefs' ++ (escapeURIString isAlphaNum $ dscName descr)++populatePopupMenu :: IDERef -> IORef (Maybe Descr) -> Menu -> IO ()+populatePopupMenu ideR currentDescr' menu = do+ items <- containerGetChildren menu+ item0 <- menuItemNewWithLabel "Goto Definition"+ item0 `onActivateLeaf` (reflectIDE gotoSource ideR)+ item1 <- menuItemNewWithLabel "Select Module"+ item1 `onActivateLeaf` (reflectIDE gotoModule' ideR )+ item2 <- menuItemNewWithLabel "Open Documentation"+ item2 `onActivateLeaf` (reflectIDE openDocu ideR )+ menuShellAppend menu item0+ menuShellAppend menu item1+ menuShellAppend menu item2+ widgetShowAll menu+ mapM_ widgetHide $ take 2 (reverse items)+ return ()
src/IDE/Pane/Log.hs view
@@ -37,7 +37,9 @@ import System.IO import Prelude hiding (catch) import Control.Exception hiding (try)-import IDE.ImportTool (addImport, parseNotInScope, addAllImports)+import IDE.ImportTool+ (addPackage, parseHiddenModule, addImport, parseNotInScope,+ resolveErrors) import IDE.System.Process (runInteractiveProcess, ProcessHandle) import Graphics.UI.Gtk (textBufferSetText, textViewScrollToMark,@@ -189,6 +191,10 @@ populatePopupMenu :: IDELog -> IDERef -> Menu -> IO () populatePopupMenu ideLog ideR menu = do items <- containerGetChildren menu+ item0 <- menuItemNewWithLabel "Resolve Errors"+ item0 `onActivateLeaf` do+ reflectIDE resolveErrors ideR+ menuShellAppend menu item0 res <- reflectIDE (do logRefs' <- readIDE allLogRefs line' <- reifyIDE $ \ideR -> do@@ -200,18 +206,22 @@ (zip logRefs' [0..(length logRefs')])) ideR case res of [(thisRef,n)] -> do- item0 <- menuItemNewWithLabel "Add all imports"- item0 `onActivateLeaf` do- reflectIDE addAllImports ideR- menuShellAppend menu item0 case parseNotInScope (refDescription thisRef) of Nothing -> do return () Just _ -> do- item1 <- menuItemNewWithLabel "Add import"+ item1 <- menuItemNewWithLabel "Add Import" item1 `onActivateLeaf` do reflectIDE (addImport thisRef [] (\_ -> return ())) ideR menuShellAppend menu item1+ case parseHiddenModule (refDescription thisRef) of+ Nothing -> do+ return ()+ Just _ -> do+ item2 <- menuItemNewWithLabel "Add Package"+ item2 `onActivateLeaf` do+ reflectIDE (addPackage thisRef >> return ()) ideR+ menuShellAppend menu item2 widgetShowAll menu return () otherwise -> return ()
src/IDE/Pane/Modules.hs view
@@ -23,6 +23,7 @@ , reloadKeepSelection , replaySelHistory , replayScopeHistory+, addModule ) where import Graphics.UI.Gtk hiding (get)@@ -41,25 +42,24 @@ import IDE.Core.State import IDE.Pane.Info import IDE.Pane.SourceBuffer-import Control.Event hiding (Event) import Distribution.ModuleName import Distribution.Text (simpleParse,display) import Data.Typeable (Typeable(..)) import Control.Exception (SomeException(..),catch)-import IDE.Package (packageConfig,addModuleToPackageDescr,getModuleTemplate,getPackageDescriptionAndPath)+import IDE.Package (packageConfig,addModuleToPackageDescr,delModuleFromPackageDescr,getModuleTemplate,getPackageDescriptionAndPath) import Distribution.PackageDescription (allBuildInfo,hsSourceDirs)-import System.FilePath ((</>),dropFileName)-import System.Directory (doesFileExist,createDirectoryIfMissing)+import System.FilePath (takeBaseName, (</>),dropFileName)+import System.Directory (doesFileExist,createDirectoryIfMissing, removeFile) import Graphics.UI.Editor.MakeEditor (buildEditor,FieldDescription(..),mkField) import Graphics.UI.Editor.Parameters (paraMultiSel,Parameter(..),emptyParams,(<<<-),paraName)-import Graphics.UI.Editor.Simple (boolEditor,okCancelFields,staticListEditor,stringEditor)-import Graphics.UI.Editor.Basics (eventPaneName,GUIEventSelector(..))+import Graphics.UI.Editor.Simple (boolEditor,staticListEditor,stringEditor) import qualified System.IO.UTF8 as UTF8 (writeFile) import IDE.Utils.GUIUtils (stockIdFromType) import IDE.Metainfo.Provider (getSystemInfo, getWorkspaceInfo, getPackageInfo) import System.Log.Logger (infoM) import Default (Default(..))+import IDE.Workspaces (packageTry_) -- | A modules pane description --@@ -695,43 +695,49 @@ -- buildModulesTree :: (SymbolTable alpha, SymbolTable beta) => (PackScope alpha,PackScope beta ) -> ModTree buildModulesTree (PackScope localMap _,PackScope otherMap _) =- let flatPairs = concatMap (\p -> map (\m -> (m,p)) (pdModules p))+ let modDescrPackDescr = concatMap (\p -> map (\m -> (m,p)) (pdModules p)) (Map.elems localMap ++ Map.elems otherMap)- resultTree = foldl' insertPairsInTree defaultRoot flatPairs+ resultTree = foldl' insertPairsInTree defaultRoot modDescrPackDescr in sortTree resultTree- where- insertPairsInTree :: ModTree -> (ModuleDescr,PackageDescr) -> ModTree- insertPairsInTree tree pair =- let nameArray = components $ modu $ mdModuleId $ fst pair- (startArray,last) = splitAt (length nameArray - 1) nameArray- pairedWith = (map (\n -> (n,Nothing)) startArray) ++ [(head last,Just pair)]- in insertNodesInTree pairedWith tree - insertNodesInTree :: [(String,Maybe (ModuleDescr,PackageDescr))] -> ModTree -> ModTree- insertNodesInTree list@[(str2,Just pair)] (Node (str1,pairs) forest) =- (Node (str1,pairs) (makeNodes list : forest))+insertPairsInTree :: ModTree -> (ModuleDescr,PackageDescr) -> ModTree+insertPairsInTree tree pair =+ let nameArray = components $ modu $ mdModuleId $ fst pair+ (startArray,last) = splitAt (length nameArray - 1) nameArray+ pairedWith = (map (\n -> (n,Nothing)) startArray) ++ [(head last,Just pair)]+ in insertNodesInTree pairedWith tree - insertNodesInTree list@((str2,pair):tl) (Node (str1,pairs) forest) =- case partition (\ (Node (s,_) _) -> s == str2) forest of- ([],_) -> (Node (str1,pairs) (makeNodes list : forest))- ([found],rest) -> (Node (str1,pairs) (insertNodesInTree tl found : rest))- (foundList,rest) -> (Node (str1,pairs) (insertNodesInTree tl (head foundList) : rest))- -- TODO make smart- insertNodesInTree [] t = t - makeNodes :: [(String,Maybe (ModuleDescr,PackageDescr))] -> ModTree- makeNodes [(str,mbPair)] = Node (str,mbPair) []- makeNodes ((str,mbPair):tl) = Node (str,mbPair) [makeNodes tl]- makeNodes _ = throwIDE "Impossible in makeNodes"+insertNodesInTree :: [(String, Maybe (ModuleDescr,PackageDescr))] -> ModTree -> ModTree+insertNodesInTree [p1@(str1,Just pair)] (Node p2@(str2,mbPair) forest2) =+ case partition (\ (Node (s,_) _) -> s == str1) forest2 of+ ([found],rest) -> case found of+ Node p3@(_,Nothing) forest3 ->+ Node p2 (Node p1 forest3 : rest)+ Node p3@(_,Just pair3) forest3 ->+ Node p2 (Node p1 [] : Node p3 forest3 : rest)+ ([],rest) -> Node p2 (Node p1 [] : forest2)+ (found,rest) -> case head found of+ Node p3@(_,Nothing) forest3 ->+ Node p2 (Node p1 forest3 : tail found ++ rest)+ Node p3@(_,Just pair3) forest3 ->+ Node p2 (Node p1 [] : Node p3 forest3 : tail found ++ rest) -breakAtDots :: [String] -> String -> [String]-breakAtDots res [] = reverse res-breakAtDots res toBreak = let (newRes,newToBreak) = span (\c -> c /= '.') toBreak- in if null newToBreak- then reverse (newRes : res)- else breakAtDots (newRes : res) (tail newToBreak)+insertNodesInTree li@(hd@(str1,Nothing):tl) (Node p@(str2,mbPair) forest) =+ case partition (\ (Node (s,_) _) -> s == str1) forest of+ ([found],rest) -> Node p (insertNodesInTree tl found : rest)+ ([],rest) -> Node p (makeNodes li : forest)+ (found,rest) -> Node p (insertNodesInTree tl (head found) : tail found ++ rest) +insertNodesInTree [] n = n+insertNodesInTree _ _ = error "Modules>>insertNodesInTree: Should not happen2" ++makeNodes :: [(String,Maybe (ModuleDescr,PackageDescr))] -> ModTree+makeNodes [(str,mbPair)] = Node (str,mbPair) []+makeNodes ((str,mbPair):tl) = Node (str,mbPair) [makeNodes tl]+makeNodes _ = throwIDE "Impossible in makeNodes"+ instance Ord a => Ord (Tree a) where compare (Node l1 _) (Node l2 _) = compare l1 l2 @@ -768,14 +774,45 @@ item5 `onActivateLeaf` (treeViewCollapseAll treeView) sep2 <- separatorMenuItemNew item6 <- menuItemNewWithLabel "Add module"- item6 `onActivateLeaf` (reflectIDE (addModule treeView store) ideR)+ item6 `onActivateLeaf` (reflectIDE (packageTry_ $ addModule' treeView store) ideR)+ item7 <- menuItemNewWithLabel "Delete module"+ item7 `onActivateLeaf` do+ sel <- getSelectionTree treeView store+ case sel of+ Just (_,Just (m,_)) -> case mdMbSourcePath m of+ Nothing -> return ()+ Just fp -> do+ resp <- reflectIDE (respDelModDialog)ideR+ if (resp == False) then return ()+ else do+ exists <- doesFileExist fp+ if exists+ then do+ reflectIDE (liftIO $ removeFile fp) ideR+ reflectIDE (packageTry_ $ delModule treeView store)ideR+ else do+ reflectIDE (packageTry_ $ delModule treeView store)ideR+ reflectIDE (packageTry_ packageConfig) ideR+ return ()+ otherwise -> return ()+ sel <- getSelectionTree treeView store+ case sel of+ Just (s, Nothing) -> do+ mapM_ (menuShellAppend theMenu) [castToMenuItem item1, castToMenuItem sep1, castToMenuItem item2,+ castToMenuItem item3, castToMenuItem item4, castToMenuItem item5, castToMenuItem sep2,+ castToMenuItem item6]+ menuPopup theMenu Nothing+ widgetShowAll theMenu+ return True+ Just (_,Just (m,_)) -> do+ mapM_ (menuShellAppend theMenu) [castToMenuItem item1, castToMenuItem sep1, castToMenuItem item2,+ castToMenuItem item3, castToMenuItem item4, castToMenuItem item5, castToMenuItem sep2,+ castToMenuItem item6, castToMenuItem item7]+ menuPopup theMenu Nothing+ widgetShowAll theMenu+ return True+ otherwise -> return True - mapM_ (menuShellAppend theMenu) [castToMenuItem item1, castToMenuItem sep1, castToMenuItem item2,- castToMenuItem item3, castToMenuItem item4, castToMenuItem item5, castToMenuItem sep2,- castToMenuItem item6{--,item7,item8--}]- menuPopup theMenu Nothing- widgetShowAll theMenu- return True else if button == LeftButton && click == DoubleClick then do sel <- getSelectionTree treeView store case sel of@@ -787,6 +824,7 @@ otherwise -> return () return True else return False+ treeViewPopup _ _ _ _ = throwIDE "treeViewPopup wrong event type" descrViewPopup :: IDERef@@ -989,41 +1027,80 @@ [] -> return () (hd:_) -> treeViewCollapseRow treeView hd >> return () -addModule :: TreeView -> TreeStore (String, Maybe (ModuleDescr,PackageDescr)) -> IDEAction-addModule treeView store = do+delModule :: TreeView -> TreeStore (String, Maybe (ModuleDescr,PackageDescr)) -> PackageAction+delModule treeview store = do+ window <- lift $ getMainWindow+ sel <- liftIO $ treeViewGetSelection treeview+ paths <- liftIO $ treeSelectionGetSelectedRows sel+ categories <- case paths of+ [] -> return []+ (treePath:_) -> liftIO $ mapM (treeStoreGetValue store)+ $ map (\n -> take n treePath) [1 .. length treePath]++ lift $ ideMessage Normal ("categories: " ++ (show categories))++ let modPacDescr = snd(last categories)+ case modPacDescr of+ Nothing -> lift $ ideMessage Normal "This should never be shown!"+ Just(md,_) -> do+ let modName = modu.mdModuleId $ md+ lift $ ideMessage Normal ("modName: " ++ (show modName))+ delModuleFromPackageDescr modName++respDelModDialog :: IDEM (Bool)+respDelModDialog = do+ window <- getMainWindow+ resp <- liftIO $ do+ dia <- messageDialogNew (Just window) [] MessageQuestion ButtonsCancel "Are you sure?"+ dialogAddButton dia "_Delete Module" (ResponseUser 1)+ dialogSetDefaultResponse dia ResponseCancel+ set dia [ windowWindowPosition := WinPosCenterOnParent ]+ resp <- dialogRun dia+ widgetDestroy dia+ return resp+ return $ resp == ResponseUser 1++addModule' :: TreeView -> TreeStore (String, Maybe (ModuleDescr,PackageDescr)) -> PackageAction+addModule' treeView store = do sel <- liftIO $ treeViewGetSelection treeView paths <- liftIO $ treeSelectionGetSelectedRows sel categories <- case paths of [] -> return [] (treePath:_) -> liftIO $ mapM (treeStoreGetValue store) $ map (\n -> take n treePath) [1 .. length treePath]- mbPD <- getPackageDescriptionAndPath+ addModule categories++addModule categories = do+ mbPD <- lift $ getPackageDescriptionAndPath case mbPD of- Nothing -> ideMessage Normal "No package description"+ Nothing -> lift $ ideMessage Normal "No package description" Just (pd,cabalPath) -> let srcPaths = nub $ concatMap hsSourceDirs $ allBuildInfo pd rootPath = dropFileName cabalPath modPath = foldr (\a b -> a ++ "." ++ b) "" (map fst categories) in do- window' <- getMainWindow+ window' <- lift getMainWindow mbResp <- liftIO $ addModuleDialog window' modPath srcPaths case mbResp of Nothing -> return () Just (AddModule modPath srcPath isExposed) -> case simpleParse modPath of- Nothing -> ideMessage Normal ("Not a valid module name :" ++ modPath)+ Nothing -> lift $ ideMessage Normal ("Not a valid module name :" ++ modPath) Just moduleName -> do let target = srcPath </> toFilePath moduleName ++ ".hs" liftIO $ createDirectoryIfMissing True (dropFileName target) alreadyExists <- liftIO $ doesFileExist target if alreadyExists- then ideMessage Normal "File already exists"+ then do+ lift $ ideMessage Normal ("File already exists! Importing existing file " ++ takeBaseName target ++ ".hs")+ addModuleToPackageDescr moduleName isExposed+ packageConfig else do template <- liftIO $ getModuleTemplate pd modPath liftIO $ UTF8.writeFile target template addModuleToPackageDescr moduleName isExposed packageConfig- fileOpenThis target+ lift $ fileOpenThis target -- Yet another stupid little dialog@@ -1039,17 +1116,20 @@ lower <- dialogGetActionArea dia (widget,inj,ext,_) <- buildEditor (moduleFields sourceRoots) (AddModule modString (head sourceRoots) False)- (widget2,_,_,notifier) <- buildEditor okCancelFields ()- registerEvent notifier Clicked (Left (\e -> do- case eventPaneName e of- "Ok" -> dialogResponse dia ResponseOk- _ -> dialogResponse dia ResponseCancel- return e))+ bb <- hButtonBoxNew+ closeB <- buttonNewFromStock "gtk-cancel"+ save <- buttonNewFromStock "gtk-ok"+ boxPackEnd bb closeB PackNatural 0+ boxPackEnd bb save PackNatural 0+ save `onClicked` (dialogResponse dia ResponseOk)+ closeB `onClicked` (dialogResponse dia ResponseCancel) boxPackStart upper widget PackGrow 7- boxPackStart lower widget2 PackNatural 7+ boxPackStart lower bb PackNatural 7+ set save [widgetCanDefault := True]+ widgetGrabDefault save widgetShowAll dia- resp <- dialogRun dia- value <- ext (AddModule modString (head sourceRoots) False)+ resp <- dialogRun dia+ value <- ext (AddModule modString (head sourceRoots) False) widgetDestroy dia --find case resp of@@ -1063,7 +1143,7 @@ $ emptyParams) moduleName (\ a b -> b{moduleName = a})- (stringEditor (\s -> True)),+ (stringEditor (const True) True), mkField (paraName <<<- ParaName ("Root of the source path") $ paraMultiSel <<<- ParaMultiSel False
src/IDE/Pane/PackageEditor.hs view
@@ -22,6 +22,7 @@ , choosePackageFile , hasConfigs+, standardSetup ) where import Graphics.UI.Gtk@@ -78,7 +79,8 @@ comboSelectionEditor, multilineStringEditor, stringEditor)-import Graphics.UI.Editor.Basics (Editor(..))+import Graphics.UI.Editor.Basics+ (Notifier, Editor(..), GUIEventSelector(..), GUIEvent(..)) import Distribution.Compiler (CompilerFlavor(..)) import Distribution.Simple@@ -87,38 +89,42 @@ VersionRange(..)) import Default (Default(..)) import IDE.Utils.GUIUtils+import IDE.Pane.SourceBuffer (fileOpenThis)+import Control.Event (EventSource(..)) #if MIN_VERSION_Cabal(1,8,0) #else import Distribution.License #endif +import qualified Graphics.UI.Gtk.Gdk.Events as GTK (Event(..))+import Data.List (sort)++ -- --------------------------------------------------------------------- -- The exported stuff goes here -- choosePackageDir :: Window -> Maybe FilePath -> IO (Maybe FilePath)-choosePackageDir window mbDir = chooseDir window "Select root folder for project" mbDir+choosePackageDir window mbDir = chooseDir window "Select root folder for package" mbDir choosePackageFile :: Window -> Maybe FilePath -> IO (Maybe FilePath) choosePackageFile window mbDir = chooseFile window "Select cabal package file (.cabal)" mbDir -packageEdit :: IDEAction+packageEdit :: PackageAction packageEdit = do- mbActivePackage <- readIDE activePack- case mbActivePackage of- Nothing -> sysMessage Normal "No active package to edit"- Just idePackage -> do- let dirName = dropFileName (ipdCabalFile idePackage)- modules <- liftIO $ allModules dirName- package <- liftIO $ readPackageDescription normal (ipdCabalFile idePackage)- if hasConfigs package- then do- 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 ())- return ()+ idePackage <- ask+ let dirName = dropFileName (ipdCabalFile idePackage)+ modules <- liftIO $ allModules dirName+ package <- liftIO $ readPackageDescription normal (ipdCabalFile idePackage)+ if hasConfigs package+ then do+ lift $ ideMessage High ("Cabal file with configurations can't be edited with the "+ ++ "current version of the editor")+ lift $ fileOpenThis $ ipdCabalFile idePackage+ return ()+ else do+ lift $ editPackage (flattenPackageDescription package) dirName modules (\ _ -> return ())+ return () hasConfigs :: GenericPackageDescription -> Bool hasConfigs gpd =@@ -143,15 +149,17 @@ cfn <- liftIO $ cabalFileName dirName continue <- do if isJust cfn- then liftIO $ do- md <- messageDialogNew Nothing [] MessageQuestion ButtonsYesNo- $ "There is already a .cabal file in this directory."- ++ " Continue anyway?"- rid <- dialogRun md- widgetDestroy md- case rid of- ResponseYes -> return True- otherwise -> return False+ then do+ window <- getMainWindow+ liftIO $ do+ md <- messageDialogNew (Just window) [] MessageQuestion ButtonsCancel+ $ "There is already a .cabal file in this directory."+ dialogAddButton md "_Continue Anyway" (ResponseUser 1)+ dialogSetDefaultResponse md (ResponseUser 1)+ set md [ windowWindowPosition := WinPosCenterOnParent ]+ rid <- dialogRun md+ widgetDestroy md+ return $ rid == ResponseUser 1 else return True when continue $ do modules <- liftIO $ do@@ -192,7 +200,14 @@ exes :: [Executable'], mbLib :: Maybe Library', bis :: [BuildInfo]}+ deriving Eq +comparePDE a b = do+ when (pd a /= pd b) $ putStrLn "pd"+ when (exes a /= exes b) $ putStrLn "exes"+ when (mbLib a /= mbLib b) $ putStrLn "mbLib"+ when (bis a /= bis b) $ putStrLn "bis"+ fromEditor :: PackageDescriptionEd -> PackageDescription fromEditor (PDE pd exes' mbLib' buildInfos) = let exes = map (\ (Executable' s fb bii) -> if bii + 1 > length buildInfos@@ -211,7 +226,7 @@ (zip (executables pd) [0 .. length (executables pd)]) (mbLib,bis2) = case library pd of Nothing -> (Nothing,bis)- Just (Library mn b bi) -> (Just (Library' mn b (length bis)), bis ++ [bi])+ Just (Library mn b bi) -> (Just (Library' (sort mn) b (length bis)), bis ++ [bi]) bis3 = if null bis2 then [emptyBuildInfo] else bis2@@ -222,7 +237,8 @@ -- data PackagePane = PackagePane {- packageBox :: VBox+ packageBox :: VBox,+ packageNotifer :: Notifier } deriving Typeable @@ -259,7 +275,7 @@ (length (bis packageEd)) (concatMap (buildInfoD (Just (takeDirectory packagePath)) modules) [0..length (bis packageEd) - 1]))- pp nb modules afterSaveAction+ pp nb modules afterSaveAction packageEd Just p -> liftIO $ bringPaneToFront p initPackage :: FilePath@@ -269,15 +285,24 @@ -> Notebook -> [ModuleName] -> (FilePath -> IDEAction)+ -> PackageDescriptionEd -> IDEM ()-initPackage packageDir packageD packageDescr panePath nb modules afterSaveAction = do+initPackage packageDir packageD packageDescr panePath nb modules afterSaveAction origPackageD = do let fields = flattenFieldDescription packageDescr let initialPackagePath = packageDir </> (display . pkgName . package . pd) packageD ++ ".cabal" packageInfos <- liftIO $ getInstalledPackageIds- buildThisPane panePath nb+ mbP <- buildThisPane panePath nb (builder' packageDir packageD packageDescr afterSaveAction- initialPackagePath modules packageInfos fields)- return ()+ initialPackagePath modules packageInfos fields origPackageD)+ case mbP of+ Nothing -> return ()+ Just (PackagePane{packageNotifer = pn}) -> do+ liftIO $ triggerEvent pn (GUIEvent {+ selector = MayHaveChanged,+ gtkEvent = GTK.Event True,+ eventText = "",+ gtkReturn = True})+ return () builder' :: FilePath -> PackageDescriptionEd ->@@ -287,97 +312,39 @@ [ModuleName] -> [PackageId] -> [FieldDescription PackageDescriptionEd] ->+ PackageDescriptionEd -> PanePath -> Notebook -> Window -> IDEM (Maybe PackagePane,Connections) builder' packageDir packageD packageDescr afterSaveAction initialPackagePath modules packageInfos fields- panePath nb window = reifyIDE $ \ ideR -> do+ origPackageD panePath nb window = reifyIDE $ \ ideR -> do vb <- vBoxNew False 0- let packagePane = PackagePane vb bb <- hButtonBoxNew- restore <- buttonNewFromStock "Revert" save <- buttonNewFromStock "gtk-save"+ widgetSetSensitive save False closeB <- buttonNewFromStock "gtk-close" addB <- buttonNewFromStock "Add Build Info" removeB <- buttonNewFromStock "Remove Build Info"+ label <- labelNew Nothing 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+ boxPackEnd bb closeB PackNatural 0+ boxPackEnd bb save PackNatural 0 (widget, setInj, getExt, notifier) <- buildEditor packageDescr packageD+ let packagePane = PackagePane vb notifier+ boxPackStart vb widget PackGrow 7+ boxPackStart vb label PackNatural 0+ boxPackEnd vb bb PackNatural 7+ 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 (closePane 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- 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- 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 (closePane packagePane >> return ()) ideR))- restore `onClicked` (do- package <- readPackageDescription normal initialPackagePath- setInj (toEditor (flattenPackageDescription package))) addB `onClicked` (do- mbNewPackage' <- extractAndValidate packageD [getExt] fieldNames+ mbNewPackage' <- extract packageD [getExt] case mbNewPackage' of Nothing -> sysMessage Normal "Content doesn't validate"- Just pde -> do- reflectIDE (do+ Just pde -> reflectIDE (do closePane packagePane initPackage packageDir pde {bis = bis pde ++ [bis pde !! 0]} (packageDD@@ -387,25 +354,68 @@ (length (bis pde) + 1) (concatMap (buildInfoD (Just packageDir) modules) [0..length (bis pde)]))- panePath nb modules afterSaveAction) ideR)+ panePath nb modules afterSaveAction origPackageD) ideR) removeB `onClicked` (do- mbNewPackage' <- extractAndValidate packageD [getExt] fieldNames+ mbNewPackage' <- extract packageD [getExt] 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+ closePane packagePane+ initPackage packageDir pde{bis = take (length (bis pde) - 1) (bis pde)}+ (packageDD+ packageInfos+ packageDir+ modules+ (length (bis pde) - 1)+ (concatMap (buildInfoD (Just packageDir) modules)+ [0..length (bis pde) - 2]))+ panePath nb modules afterSaveAction origPackageD) ideR)+ closeB `onClicked` (do+ mbP <- extract packageD [getExt]+ let hasChanged = case mbP of+ Nothing -> False+ Just p -> p /= origPackageD+ if not hasChanged+ then reflectIDE (closePane packagePane >> return ()) ideR+ else do+ md <- messageDialogNew (Just window) []+ MessageQuestion+ ButtonsYesNo+ "Unsaved changes. Close anyway?"+ set md [ windowWindowPosition := WinPosCenterOnParent ]+ resp <- dialogRun md+ widgetDestroy md+ case resp of+ ResponseYes -> do+ reflectIDE (closePane packagePane >> return ()) ideR+ _ -> return ())+ save `onClicked` (do+ mbNewPackage' <- extract packageD [getExt]+ 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 (do+ afterSaveAction packagePath closePane packagePane- initPackage packageDir pde{bis = take (length (bis pde) - 1) (bis pde)}- (packageDD- 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 ()) ideR)+ registerEvent notifier MayHaveChanged (\ e -> do+ mbP <- extract packageD [getExt]+ let hasChanged = case mbP of+ Nothing -> False+ Just p -> p /= origPackageD+ when (isJust mbP) $ labelSetMarkup label ""+ when (isJust mbP) $ comparePDE (fromJust mbP) packageD+ markLabel nb (getTopWidget packagePane) hasChanged+ widgetSetSensitive save hasChanged+ return (e{gtkReturn=False}))+ registerEvent notifier ValidationError (\e -> do+ labelSetMarkup label $ "<span foreground=\"red\" size=\"x-large\">The following fields have invalid values: "+ ++ eventText e ++ "</span>"+ return e) return (Just packagePane,[]) -- ---------------------------------------------------------------------@@ -426,7 +436,7 @@ $ emptyParams) (synopsis . pd) (\ a b -> b{pd = (pd b){synopsis = a}})- (stringEditor (const True))+ (stringEditor (const True) True) , mkField (paraName <<<- ParaName "Package Identifier" $ emptyParams) (package . pd)@@ -445,24 +455,24 @@ (paraName <<<- ParaName "Homepage" $ emptyParams) (homepage . pd) (\ a b -> b{pd = (pd b){homepage = a}})- (stringEditor (const True))+ (stringEditor (const True) True) , mkField (paraName <<<- ParaName "Package URL" $ emptyParams) (pkgUrl . pd) (\ a b -> b{pd = (pd b){pkgUrl = a}})- (stringEditor (const True))+ (stringEditor (const True) True) , mkField (paraName <<<- ParaName "Category" $ emptyParams) (category . pd) (\ a b -> b{pd = (pd b){category = a}})- (stringEditor (const True))+ (stringEditor (const True) True) ]), ("Description", VFD emptyParams [ mkField (paraName <<<- ParaName "Stability" $ emptyParams) (stability . pd) (\ a b -> b{pd = (pd b){stability = a}})- (stringEditor (const True))+ (stringEditor (const True) True) #if MIN_VERSION_Cabal(1,8,0) -- TODO #else@@ -481,22 +491,22 @@ (paraName <<<- ParaName "Copyright" $ emptyParams) (copyright . pd) (\ a b -> b{pd = (pd b){copyright = a}})- (stringEditor (const True))+ (stringEditor (const True) True) , mkField (paraName <<<- ParaName "Author" $ emptyParams) (author . pd) (\ a b -> b{pd = (pd b){author = a}})- (stringEditor (const True))+ (stringEditor (const True) True) , mkField (paraName <<<- ParaName "Maintainer" $ emptyParams) (maintainer . pd) (\ a b -> b{pd = (pd b){maintainer = a}})- (stringEditor (const True))+ (stringEditor (const True) True) , mkField (paraName <<<- ParaName "Bug Reports" $ emptyParams) (bugReports . pd) (\ a b -> b{pd = (pd b){bugReports = a}})- (stringEditor (const True))+ (stringEditor (const True) True) ]), -- ("Repositories", VFD emptyParams [ -- mkField@@ -511,7 +521,7 @@ $ paraDirection <<<- ParaDirection Vertical $ paraMinSize <<<- ParaMinSize (-1,250) $ emptyParams)- (reverse . buildDepends . pd)+ (buildDepends . pd) (\ a b -> b{pd = (pd b){buildDepends = a}}) (dependenciesEditor packages) ]),@@ -522,7 +532,11 @@ "Does this package depends on a specific version of Cabal?" $ paraShadow <<<- ParaShadow ShadowIn $ emptyParams) (descCabalVersion . pd)+#if MIN_VERSION_Cabal(1,10,0)+ (\ a b -> b{pd = (pd b){specVersionRaw = Right a}})+#else (\ a b -> b{pd = (pd b){descCabalVersion = a}})+#endif versionRangeEditor , mkField (paraName <<<- ParaName "Tested with compiler"@@ -596,7 +610,7 @@ ,("Value",\(_,v) -> [cellText := v])]) ((pairEditor (stringxEditor (const True),emptyParams)- (stringEditor (const True),emptyParams)),emptyParams)+ (stringEditor (const True) True,emptyParams)),emptyParams) Nothing Nothing) ]),@@ -706,8 +720,13 @@ $ paraMinSize <<<- ParaMinSize (-1,400) $ paraPack <<<- ParaPack PackGrow $ emptyParams)+#if MIN_VERSION_Cabal(1,10,0)+ (oldExtensions . (\a -> a !! i) . bis)+ (\ a b -> b{bis = update (bis b) i (\bi -> bi{oldExtensions = a})})+#else (extensions . (\a -> a !! i) . bis) (\ a b -> b{bis = update (bis b) i (\bi -> bi{extensions = a})})+#endif extensionsEditor ]), (show (i + 1) ++ " Build Tools ", VFD emptyParams [@@ -750,7 +769,7 @@ $ paraDirection <<<- ParaDirection Vertical $ emptyParams) (includes . (\a -> a !! i) . bis) (\ a b -> b{bis = update (bis b) i (\bi -> bi{includes = a})})- (stringsEditor (const True))+ (stringsEditor (const True) True) , mkField (paraName <<<- ParaName "A list of header files to install" $ paraDirection <<<- ParaDirection Vertical $ emptyParams)@@ -779,7 +798,7 @@ $ paraDirection <<<- ParaDirection Vertical $ emptyParams) (extraLibs . (\a -> a !! i) . bis) (\ a b -> b{bis = update (bis b) i (\bi -> bi{extraLibs = a})})- (stringsEditor (const True))+ (stringsEditor (const True) True) , mkField (paraName <<<- ParaName "A list of directories to search for libraries." $ paraDirection <<<- ParaDirection Vertical $ emptyParams)@@ -793,7 +812,7 @@ $ paraDirection <<<- ParaDirection Vertical $ emptyParams) (frameworks . (\a -> a !! i) . bis) (\ a b -> b{bis = update (bis b) i (\bi -> bi{frameworks = a})})- (stringsEditor (const True))+ (stringsEditor (const True) True) , mkField (paraName <<<- ParaName "Custom fields build info" $ paraShadow <<<- ParaShadow ShadowIn@@ -805,14 +824,14 @@ ,("Value",\(_,v) -> [cellText := v])]) ((pairEditor (stringxEditor (const True),emptyParams)- (stringEditor (const True),emptyParams)),emptyParams)+ (stringEditor (const True) True,emptyParams)),emptyParams) Nothing Nothing) ])] stringxEditor :: (String -> Bool) -> Editor String stringxEditor val para noti = do- (wid,inj,ext) <- stringEditor val para noti+ (wid,inj,ext) <- stringEditor val True para noti let xinj ("") = inj "" xinj ('x':'-':rest) = inj rest@@ -826,7 +845,7 @@ optsEditor :: Editor [String] optsEditor para noti = do- (wid,inj,ext) <- stringEditor (const True) para noti+ (wid,inj,ext) <- stringEditor (const True) True para noti let oinj = inj . unwords oext = do@@ -839,7 +858,7 @@ packageEditor :: Editor PackageIdentifier packageEditor para noti = do (wid,inj,ext) <- pairEditor- (stringEditor (\s -> not (null s)), paraName <<<- ParaName "Name" $ emptyParams)+ (stringEditor (\s -> not (null s)) True, paraName <<<- ParaName "Name" $ emptyParams) (versionEditor, paraName <<<- ParaName "Version" $ emptyParams) (paraDirection <<<- ParaDirection Horizontal $ paraShadow <<<- ParaShadow ShadowIn@@ -872,7 +891,7 @@ compilerFlavorEditor para noti = do (wid,inj,ext) <- eitherOrEditor (comboSelectionEditor flavors show, paraName <<<- (ParaName "Select compiler") $ emptyParams)- (stringEditor (\s -> not (null s)), paraName <<<- (ParaName "Specify compiler") $ emptyParams)+ (stringEditor (\s -> not (null s)) True, paraName <<<- (ParaName "Specify compiler") $ emptyParams) "Other" (paraName <<<- ParaName "Select" $ para) noti@@ -893,7 +912,7 @@ buildTypeEditor para noti = do (wid,inj,ext) <- eitherOrEditor (comboSelectionEditor flavors show, paraName <<<- (ParaName "Select") $ emptyParams)- (stringEditor (const True), paraName <<<- (ParaName "Unknown") $ emptyParams)+ (stringEditor (const True) True, paraName <<<- (ParaName "Unknown") $ emptyParams) "Unknown" (paraName <<<- ParaName "Select" $ para) noti@@ -951,11 +970,11 @@ (widg,inj,ext) <- tupel7Editor (repoKindEditor,noBorder) (maybeEditor (repoTypeEditor,noBorder) True "Specify a type", emptyParams)- (maybeEditor (stringEditor (const True),noBorder) True "Specify a location", emptyParams)- (maybeEditor (stringEditor (const True),noBorder) True "Specify a module", emptyParams)- (maybeEditor (stringEditor (const True),noBorder) True "Specify a branch", emptyParams)- (maybeEditor (stringEditor (const True),noBorder) True "Specify a tag", emptyParams)- (maybeEditor (stringEditor (const True),noBorder) True "Specify a subdir", emptyParams)+ (maybeEditor (stringEditor (const True) True,noBorder) True "Specify a location", emptyParams)+ (maybeEditor (stringEditor (const True) True,noBorder) True "Specify a module", emptyParams)+ (maybeEditor (stringEditor (const True) True,noBorder) True "Specify a branch", emptyParams)+ (maybeEditor (stringEditor (const True) True,noBorder) True "Specify a tag", emptyParams)+ (maybeEditor (stringEditor (const True) True,noBorder) True "Specify a subdir", emptyParams) (paraDirection <<<- ParaDirection Vertical $ noBorder) noti return (widg,@@ -975,7 +994,7 @@ repoKindEditor paras noti = do (widg,inj,ext) <- pairEditor (comboSelectionEditor selectionList show, emptyParams)- (stringEditor (const True),emptyParams)+ (stringEditor (const True) True,emptyParams) paras noti return (widg,@@ -994,7 +1013,7 @@ repoTypeEditor paras noti = do (widg,inj,ext) <- pairEditor (comboSelectionEditor selectionList show, emptyParams)- (stringEditor (const True),emptyParams)+ (stringEditor (const True) True,emptyParams) paras noti return (widg,@@ -1041,7 +1060,7 @@ paraName <<<- ParaName "Exposed" $ paraSynopsis <<<- ParaSynopsis "Is the lib to be exposed by default?" $ emptyParams)- (modulesEditor modules,+ (modulesEditor (sort modules), paraName <<<- ParaName "Exposed Modules" $ paraMinSize <<<- ParaMinSize (-1,300) $ para)@@ -1081,10 +1100,10 @@ executableEditor :: Maybe FilePath -> [ModuleName] -> Int -> Editor Executable' executableEditor fp modules countBuildInfo para noti = do (wid,inj,ext) <- tupel3Editor- (stringEditor (\s -> not (null s)),+ (stringEditor (\s -> not (null s)) True, paraName <<<- ParaName "Executable Name" $ emptyParams)- (stringEditor (\s -> not (null s)),+ (stringEditor (\s -> not (null s)) True, paraDirection <<<- ParaDirection Vertical $ paraName <<<- ParaName "File with main function" $ emptyParams)
src/IDE/Pane/PackageFlags.hs view
@@ -41,6 +41,8 @@ FieldDescriptionPP(..), mkFieldPP) import Text.ParserCombinators.Parsec hiding(Parser)+import Debug.Trace (trace)+import Control.Monad.Trans (liftIO) data IDEFlags = IDEFlags { flagsBox :: VBox@@ -85,16 +87,17 @@ 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+ saveB <- buttonNewFromStock "gtk-save"+ widgetSetSensitive saveB False+ cancelB <- buttonNewFromStock "gtk-cancel"+ boxPackStartDefaults bb cancelB+ boxPackStartDefaults bb saveB (widget,injb,ext,notifier) <- buildEditor flagsDesc idePackage sw <- scrolledWindowNew Nothing Nothing scrolledWindowAddWithViewport sw widget scrolledWindowSetPolicy sw PolicyAutomatic PolicyAutomatic- ok `onClicked` (do+ saveB `onClicked` (do mbPackWithNewFlags <- extract idePackage [ext] case mbPackWithNewFlags of Nothing -> return ()@@ -104,10 +107,19 @@ closePane flagsPane) ideR -- we don't trigger the activePack event here writeFields ((dropExtension (ipdCabalFile packWithNewFlags)) ++ leksahFlagFileExtension) packWithNewFlags flatFlagsDescription)- closeB `onClicked` (reflectIDE (closePane flagsPane >> return ()) ideR)- registerEvent notifier FocusIn (Left (\e -> do+ cancelB `onClicked` (reflectIDE (closePane flagsPane >> return ()) ideR)+ registerEvent notifier FocusIn (\e -> do reflectIDE (makeActive flagsPane) ideR- return (e{gtkReturn=False})))+ return (e{gtkReturn=False}))+ registerEvent notifier MayHaveChanged (\e -> do+ mbP <- extract idePackage [ext]+ let hasChanged = case mbP of+ Nothing -> False+ Just p -> p /= idePackage+ markLabel nb (getTopWidget flagsPane) hasChanged+ widgetSetSensitive saveB hasChanged+ return (e{gtkReturn=False}))+ boxPackStart vb sw PackGrow 7 boxPackEnd vb bb PackNatural 7 return (Just flagsPane,[])@@ -166,7 +178,7 @@ stringParser (\p -> unargs (ipdConfigFlags p)) (\ b a -> a{ipdConfigFlags = args b})- (stringEditor (const True))+ (stringEditor (const True) True) (\ _ -> return ()) , mkFieldPP (paraName <<<- ParaName "Build flags" $ emptyParams)@@ -174,7 +186,7 @@ stringParser (\p -> unargs (ipdBuildFlags p)) (\ b a -> a{ipdBuildFlags = args b})- (stringEditor (const True))+ (stringEditor (const True) True) (\ _ -> return ()) , mkFieldPP (paraName <<<- ParaName "Haddock flags" $ emptyParams)@@ -182,7 +194,7 @@ stringParser (\p -> unargs (ipdHaddockFlags p)) (\ b a -> a{ipdHaddockFlags = args b})- (stringEditor (const True))+ (stringEditor (const True) True) (\ _ -> return ()) , mkFieldPP (paraName <<<- ParaName "Executable flags" $ emptyParams)@@ -190,7 +202,7 @@ stringParser (\p -> unargs (ipdExeFlags p)) (\ b a -> a{ipdExeFlags = args b})- (stringEditor (const True))+ (stringEditor (const True) True) (\ _ -> return ()) , mkFieldPP (paraName <<<- ParaName "Install flags" $ emptyParams)@@ -198,7 +210,7 @@ stringParser (\p -> unargs (ipdInstallFlags p)) (\ b a -> a{ipdInstallFlags = args b})- (stringEditor (const True))+ (stringEditor (const True) True) (\ _ -> return ()) , mkFieldPP (paraName <<<- ParaName "Register flags" $ emptyParams)@@ -206,7 +218,7 @@ stringParser (\p -> unargs (ipdRegisterFlags p)) (\ b a -> a{ipdRegisterFlags = args b})- (stringEditor (const True))+ (stringEditor (const True) True) (\ _ -> return ()) , mkFieldPP (paraName <<<- ParaName "Unregister flags" $ emptyParams)@@ -214,7 +226,7 @@ stringParser (\p -> unargs (ipdUnregisterFlags p)) (\ b a -> a{ipdUnregisterFlags = args b})- (stringEditor (const True))+ (stringEditor (const True) True) (\ _ -> return ()) , mkFieldPP (paraName <<<- ParaName "Source Distribution flags" $ emptyParams)@@ -222,7 +234,7 @@ stringParser (\p -> unargs (ipdSdistFlags p)) (\ b a -> a{ipdSdistFlags = args b})- (stringEditor (const True))+ (stringEditor (const True) True) (\ _ -> return ())] -- ------------------------------------------------------------
src/IDE/Pane/Preferences.hs view
@@ -28,10 +28,12 @@ ) where import Graphics.UI.Gtk- (cellText, widgetModifyFont, onClicked, boxPackEnd, boxPackStart,+ (widgetDestroy, dialogRun, windowWindowPosition, dialogAddButton,+ messageDialogNew, labelSetMarkup, labelNew, widgetSetSensitive,+ cellText, widgetModifyFont, onClicked, boxPackEnd, boxPackStart, buttonNewFromStock, hButtonBoxNew, vBoxNew, castToWidget, VBox, ShadowType(..), Packing(..), fontDescriptionFromString, AttrOp(..),- FileChooserAction(..), Color(..))+ FileChooserAction(..), Color(..), ResponseId(..)) import Control.Monad.Reader import qualified Text.PrettyPrint.HughesPJ as PP import Distribution.Package@@ -50,7 +52,6 @@ import IDE.TextEditor import IDE.Pane.SourceBuffer import IDE.Pane.Log-import Default import IDE.Utils.FileUtils import IDE.Utils.GUIUtils import IDE.Debug@@ -61,16 +62,21 @@ import Graphics.UI.Gtk.SourceView (sourceStyleSchemeManagerGetSchemeIds, sourceStyleSchemeManagerNew) import System.Time (getClockTime)-import System.FilePath((</>)) import qualified IDE.StrippedPrefs as SP import Control.Exception(SomeException,catch) import Prelude hiding(catch)+import Data.List (sortBy)+import Data.Maybe (isJust)+import Graphics.UI.Gtk.Windows.MessageDialog+ (ButtonsType(..), MessageType(..))+import System.Glib.Attributes (set)+import Graphics.UI.Gtk.General.Enums (WindowPosition(..)) -- --------------------------------------------------------------------- -- This needs to be incremented, when the preferences format changes -- prefsVersion :: Int-prefsVersion = 1+prefsVersion = 2 -- -- | The Preferences Pane@@ -104,15 +110,18 @@ bb <- hButtonBoxNew apply <- buttonNewFromStock "gtk-apply" restore <- buttonNewFromStock "Restore"+ closeB <- buttonNewFromStock "gtk-cancel" save <- buttonNewFromStock "gtk-save"- closeB <- buttonNewFromStock "gtk-close"+ widgetSetSensitive save False boxPackStart bb apply PackNatural 0 boxPackStart bb restore PackNatural 0- boxPackStart bb save PackNatural 0- boxPackStart bb closeB PackNatural 0+ boxPackEnd bb closeB PackNatural 0+ boxPackEnd bb save PackNatural 0 (widget,injb,ext,notifier) <- buildEditor (extractFieldDescription $ prefsDescription configDir packageInfos) prefs boxPackStart vb widget PackGrow 7+ label <- labelNew Nothing+ boxPackStart vb label PackNatural 0 boxPackEnd vb bb PackNatural 7 let prefsPane = IDEPrefs vb apply `onClicked` (do@@ -127,29 +136,66 @@ lastAppliedPrefs <- readIORef lastAppliedPrefsRef mapM_ (\ (FDPP _ _ _ _ applyF) -> reflectIDE (applyF prefs lastAppliedPrefs) ideR ) flatPrefsDesc injb prefs- writeIORef lastAppliedPrefsRef prefs)+ writeIORef lastAppliedPrefsRef prefs+ markLabel nb (getTopWidget prefsPane) False+ widgetSetSensitive save False+ ) 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 standardPreferencesFilename- writePrefs fp newPrefs- fp2 <- getConfigFilePathForSave strippedPreferencesFilename- SP.writeStrippedPrefs fp2- (SP.Prefs {SP.sourceDirectories = sourceDirectories newPrefs,- SP.unpackDirectory = unpackDirectory newPrefs,- SP.retrieveURL = retrieveURL newPrefs,- SP.retrieveStrategy = retrieveStrategy newPrefs,- SP.serverPort = serverPort newPrefs,- SP.endWithLastConn = endWithLastConn newPrefs})- reflectIDE (modifyIDE_ (\ide -> ide{prefs = newPrefs})) ideR )- closeB `onClicked` (reflectIDE (closePane prefsPane >> return ()) ideR )- registerEvent notifier FocusIn (Left (\e -> do+ mapM_ (\ (FDPP _ _ _ _ applyF) -> reflectIDE (applyF newPrefs lastAppliedPrefs) ideR ) flatPrefsDesc+ fp <- getConfigFilePathForSave standardPreferencesFilename+ writePrefs fp newPrefs+ fp2 <- getConfigFilePathForSave strippedPreferencesFilename+ SP.writeStrippedPrefs fp2+ (SP.Prefs {SP.sourceDirectories = sourceDirectories newPrefs,+ SP.unpackDirectory = unpackDirectory newPrefs,+ SP.retrieveURL = retrieveURL newPrefs,+ SP.retrieveStrategy = retrieveStrategy newPrefs,+ SP.serverPort = serverPort newPrefs,+ SP.endWithLastConn = endWithLastConn newPrefs})+ reflectIDE (modifyIDE_ (\ide -> ide{prefs = newPrefs})) ideR+ reflectIDE (closePane prefsPane >> return ()) ideR)+ closeB `onClicked` do+ mbP <- extract prefs [ext]+ let hasChanged = case mbP of+ Nothing -> False+ Just p -> p{prefsFormat = 0, prefsSaveTime = ""} /=+ prefs{prefsFormat = 0, prefsSaveTime = ""}+ if not hasChanged+ then reflectIDE (closePane prefsPane >> return ()) ideR+ else do+ md <- messageDialogNew (Just windows) []+ MessageQuestion+ ButtonsYesNo+ "Unsaved changes. Close anyway?"+ set md [ windowWindowPosition := WinPosCenterOnParent ]+ resp <- dialogRun md+ widgetDestroy md+ case resp of+ ResponseYes -> do+ reflectIDE (closePane prefsPane >> return ()) ideR+ _ -> return ()+ registerEvent notifier FocusIn (\e -> do reflectIDE (makeActive prefsPane) ideR- return (e{gtkReturn=False})))+ return (e{gtkReturn=False}))+ registerEvent notifier MayHaveChanged (\ e -> do+ mbP <- extract prefs [ext]+ let hasChanged = case mbP of+ Nothing -> False+ Just p -> p{prefsFormat = 0, prefsSaveTime = ""} /=+ prefs{prefsFormat = 0, prefsSaveTime = ""}+ when (isJust mbP) $ labelSetMarkup label ""+ markLabel nb (getTopWidget prefsPane) hasChanged+ widgetSetSensitive save hasChanged+ return (e{gtkReturn=False}))+ registerEvent notifier ValidationError (\e -> do+ labelSetMarkup label $ "<span foreground=\"red\" size=\"x-large\">The following fields have invalid values: "+ ++ eventText e ++ "</span>"+ return e) return (Just prefsPane,[]) getPrefs :: Maybe PanePath -> IDEM IDEPrefs@@ -209,17 +255,19 @@ (paraName <<<- ParaName "Right margin" $ paraSynopsis <<<- ParaSynopsis "Size or 0 for no right margin" $ paraShadow <<<- ParaShadow ShadowIn $ emptyParams)- (\a -> (PP.text . show) (case a of Nothing -> 0; Just i -> i))- (do i <- intParser- return (if i == 0 then Nothing else Just i))+ (PP.text . show)+ readParser rightMargin (\b a -> a{rightMargin = b})- (maybeEditor (intEditor (1.0, 200.0, 5.0), paraName <<<- ParaName "Position"+ (disableEditor (intEditor (1.0, 200.0, 5.0), paraName <<<- ParaName "Position" $ emptyParams) True "Show it ?") (\b -> do buffers <- allBuffers- mapM_ (\buf -> setRightMargin (sourceView buf) b) buffers)+ mapM_ (\buf -> setRightMargin (sourceView buf)+ (case b of+ (True,v) -> Just v+ (False,_) -> Nothing)) buffers) , mkFieldPP (paraName <<<- ParaName "Tab width" $ emptyParams) (PP.text . show)@@ -231,6 +279,16 @@ buffers <- allBuffers mapM_ (\buf -> setIndentWidth (sourceView buf) i) buffers) , mkFieldPP+ (paraName <<<- ParaName "Wrap lines" $ emptyParams)+ (PP.text . show)+ boolParser+ wrapLines+ (\b a -> a{wrapLines = b})+ boolEditor+ (\b -> do+ buffers <- allBuffers+ mapM_ (\buf -> setWrapMode (sourceView buf) b) buffers)+ , mkFieldPP (paraName <<<- ParaName "Use standard line ends even on windows" $ emptyParams) (PP.text . show) boolParser@@ -251,25 +309,25 @@ $ paraSynopsis <<<- ParaSynopsis "Empty for do not use or the name of a candy file in a config dir" $ paraShadow <<<- ParaShadow ShadowIn $ emptyParams)- (\a -> PP.text (case a of Nothing -> show ""; Just s -> show s))- (do str <- stringParser- return (if null str then Nothing else Just (str)))+ (PP.text . show)+ readParser sourceCandy (\b a -> a{sourceCandy = b})- (maybeEditor ((stringEditor (\s -> not (null s))), paraName <<<- ParaName "Candy specification"+ (disableEditor (stringEditor (\s -> not (null s)) True,+ paraName <<<- ParaName "Candy specification" $ emptyParams) True "Use it ?") (\cs -> case cs of- Nothing -> do+ (False,_) -> do setCandyState False editCandy- Just name -> do+ (True,name) -> do setCandyState True editCandy) , mkFieldPP (paraName <<<- ParaName "Editor Style" $ emptyParams)- (\a -> PP.text (case a of Nothing -> show ""; Just s -> show s))+ (\a -> PP.text (case a of (False,_) -> show ""; (True, s) -> show s)) (do str <- stringParser- return (if null str then Nothing else Just (str)))+ return (if null str then (False,"classic") else (True,str))) sourceStyle (\b a -> a{sourceStyle = b}) styleEditor@@ -277,7 +335,9 @@ buffers <- allBuffers mapM_ (\buf -> do ebuf <- getBuffer (sourceView buf)- setStyle ebuf mbs) buffers)+ setStyle ebuf (case mbs of+ (False,_) -> Nothing+ (True,s) -> Just s)) buffers) , mkFieldPP (paraName <<<- ParaName "Found Text Background" $ emptyParams) (PP.text . show)@@ -323,6 +383,14 @@ -- TODO find and set the tag background return ()) , mkFieldPP+ (paraName <<<- ParaName "Automatically load modified files modified outside of Leksah" $ emptyParams)+ (PP.text . show)+ boolParser+ autoLoad+ (\b a -> a{autoLoad = b})+ boolEditor+ (\i -> return ())+ , mkFieldPP (paraName <<<- ParaName "Use Yi - Experimental feature (could wipe your files)" $ emptyParams) (PP.text . show) boolParser@@ -382,7 +450,7 @@ identifier keymapName (\b a -> a{keymapName = b})- (stringEditor (\s -> not (null s)))+ (stringEditor (\s -> not (null s)) True) (\ a -> return ()) ]), ("Initial Pane positions", VFDPP emptyParams [@@ -390,7 +458,9 @@ (paraName <<<- ParaName "Categories for panes" $ paraShadow <<<- ParaShadow ShadowIn- $ paraDirection <<<- ParaDirection Vertical $ emptyParams)+ $ paraDirection <<<- ParaDirection Vertical+ $ paraMinSize <<<- ParaMinSize (-1,130)+ $ emptyParams) (PP.text . show) readParser categoryForPane@@ -399,16 +469,18 @@ (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)+ (stringEditor (\s -> not (null s)) True,emptyParams)+ (stringEditor (\s -> not (null s)) True,emptyParams)),emptyParams)+ (Just (sortBy (\(a,_) (a2,_) -> compare a a2)))+ (Just (\(a,_) (a2,_) -> a == a2))) (\i -> return ()) , mkFieldPP (paraName <<<- ParaName "Pane path for category" $ paraShadow <<<- ParaShadow ShadowIn- $ paraDirection <<<- ParaDirection Vertical $ emptyParams)+ $ paraDirection <<<- ParaDirection Vertical+ $ paraMinSize <<<- ParaMinSize (-1,130)+ $ emptyParams) (PP.text . show) readParser pathForCategory@@ -417,10 +489,10 @@ (ColumnDescr True [("Pane category",\(n,_) -> [cellText := n]) ,("Pane path",\(_,v) -> [cellText := show v])]) ((pairEditor- (stringEditor (\s -> not (null s)),emptyParams)+ (stringEditor (\s -> not (null s)) True,emptyParams) (genericEditor,emptyParams)),emptyParams)- Nothing- Nothing)+ (Just (sortBy (\(a,_) (a2,_) -> compare a a2)))+ (Just (\(a,_) (a2,_) -> a == a2))) (\i -> return ()) , mkFieldPP (paraName <<<- ParaName "Default pane path" $ emptyParams)@@ -434,7 +506,9 @@ ("Metadata", VFDPP emptyParams [ mkFieldPP (paraName <<<- ParaName- "Paths under which haskell sources for packages may be found" $ emptyParams)+ "Paths under which haskell sources for packages may be found"+ $ paraMinSize <<<- ParaMinSize (-1,100)+ $ emptyParams) (PP.text . show) readParser sourceDirectories@@ -442,28 +516,28 @@ (filesEditor Nothing FileChooserActionSelectFolder "Select folder") (\i -> return ()) , mkFieldPP- (paraName <<<- ParaName "Maybe a directory for unpacking cabal packages" $ emptyParams)+ (paraName <<<- ParaName "Unpack source for cabal packages to" $ emptyParams) (PP.text . show) readParser unpackDirectory (\b a -> a{unpackDirectory = b})- (maybeEditor (stringEditor (\ _ -> True),emptyParams) True "")+ (maybeEditor (stringEditor (\ _ -> True) True,emptyParams) True "") (\i -> return ()) , mkFieldPP- (paraName <<<- ParaName "An URL to load prebuild metadata" $ emptyParams)+ (paraName <<<- ParaName "URL from which to download prebuilt metadata" $ emptyParams) (PP.text . show) stringParser retrieveURL (\b a -> a{retrieveURL = b})- (stringEditor (\ _ -> True))+ (stringEditor (const True) True) (\i -> return ()) , mkFieldPP- (paraName <<<- ParaName "A strategy for downloading prebuild metadata" $ emptyParams)+ (paraName <<<- ParaName "Strategy for downloading prebuilt metadata" $ emptyParams) (PP.text . show) readParser retrieveStrategy (\b a -> a{retrieveStrategy = b})- (enumEditor ["Retrieve then build","Build then retrieve","Never retrieve"])+ (enumEditor ["Try to download and then build locally if that fails","Try to build locally and then download if that fails","Never download (just try to build locally)"]) (\i -> return ()) , mkFieldPP (paraName <<<- ParaName "Update metadata at startup" $ emptyParams)@@ -474,7 +548,7 @@ boolEditor (\i -> return ()) , mkFieldPP- (paraName <<<- ParaName "Port number for server connection" $ emptyParams)+ (paraName <<<- ParaName "Port number for leksah to comunicate with leksah-server" $ emptyParams) (PP.text . show) intParser serverPort@@ -482,15 +556,15 @@ (intEditor (1.0, 65535.0, 1.0)) (\i -> return ()) , mkFieldPP- (paraName <<<- ParaName "Server IP address " $ emptyParams)+ (paraName <<<- ParaName "IP address for leksah to comunicate with leksah-server" $ emptyParams) (PP.text . show) stringParser serverIP (\b a -> a{serverIP = b})- (stringEditor (\ s -> not $ null s))+ (stringEditor (\ s -> not $ null s) True) (\i -> return ()) , mkFieldPP- (paraName <<<- ParaName "End the server with last connection" $ emptyParams)+ (paraName <<<- ParaName "Stop the leksah-server process when leksah disconnects" $ emptyParams) (PP.text . show) boolParser endWithLastConn@@ -501,7 +575,9 @@ ("Blacklist", VFDPP emptyParams [ mkFieldPP (paraName <<<- ParaName- "Packages which are excluded from the modules pane" $ emptyParams)+ "Packages which are excluded from the modules pane"+ $ paraMinSize <<<- ParaMinSize (-1,200)+ $ emptyParams) (PP.text . show) readParser packageBlacklist@@ -541,8 +617,8 @@ readParser autoInstall (\b a -> a{autoInstall = b})- (enumEditor ["Install always after a succesful build",- "Install if it's a library with dependend packages in the workspace",+ (enumEditor ["Install always after a successful build",+ "Install if it's a library with dependent packages in the workspace", "Never install"]) (\i -> return ()) ]),@@ -587,7 +663,7 @@ stringParser browser (\b a -> a{browser = b})- (stringEditor (\s -> not (null s)))+ (stringEditor (\s -> not (null s)) True) (\i -> return ()) , mkFieldPP (paraName <<<- ParaName "URL for searching documentation" $@@ -599,51 +675,54 @@ stringParser docuSearchURL (\b a -> a{docuSearchURL = b})- (stringEditor (\s -> not (null s)))+ (stringEditor (\s -> not (null s)) True) (\i -> return ()) ])] -styleEditor :: Editor (Maybe String)+styleEditor :: Editor (Bool, String) styleEditor p n = do styleManager <- sourceStyleSchemeManagerNew ids <- sourceStyleSchemeManagerGetSchemeIds styleManager- maybeEditor (comboSelectionEditor ids id, p) True "Select a special style?" p n+ disableEditor (comboSelectionEditor ids id, p) True "Select a special style?" p n defaultPrefs = Prefs { prefsFormat = prefsVersion , prefsSaveTime = "" , showLineNumbers = True- , rightMargin = Just 100+ , rightMargin = (True,100) , tabWidth = 4- , sourceCandy = Just("candy")+ , wrapLines = False+ , sourceCandy = (False,"candy") , keymapName = "keymap" , forceLineEnds = True , removeTBlanks = True , textviewFont = Nothing- , sourceStyle = Nothing+ , sourceStyle = (False,"classic") , foundBackground = Color 65535 65535 32768 , contextBackground = Color 65535 49152 49152 , breakpointBackground = Color 65535 49152 32768 , useYi = False+ , autoLoad = False , logviewFont = Nothing , defaultSize = (1024,800) , browser = "firefox" , sourceDirectories = [] , packageBlacklist = [] , pathForCategory = [ ("EditorCategory",[SplitP (LeftP)])+ , ("LogCategory",[SplitP (RightP), SplitP (BottomP)]) , ("ToolCategory",[SplitP (RightP),SplitP (TopP)])- , ("LogCategory",[SplitP (RightP), SplitP (BottomP)])]+ ] , defaultPath = [SplitP (LeftP)] , categoryForPane = [ ("*ClassHierarchy","ToolCategory") , ("*Debug","ToolCategory")+ , ("*Flags","ToolCategory") , ("*Grep","ToolCategory") , ("*Info","ToolCategory") , ("*Log","LogCategory") , ("*Modules","ToolCategory") , ("*Package","ToolCategory")- , ("*Flags","ToolCategory") , ("*Prefs","ToolCategory") , ("*References","ToolCategory") , ("*Search","ToolCategory")]@@ -652,7 +731,7 @@ , retrieveURL = "http://www.leksah.org" , retrieveStrategy = SP.RetrieveThenBuild , useCtrlTabFlipping = True- , docuSearchURL = "http://holumbus.fh-wedel.de/hayoo/hayoo.html?query="+ , docuSearchURL = "http://www.holumbus.org/hayoo/hayoo.html?query=" , completeRestricted = False , saveAllBeforeBuild = True , backgroundBuild = True
− src/IDE/Pane/References.hs
@@ -1,314 +0,0 @@-{-# OPTIONS_GHC -XDeriveDataTypeable -XMultiParamTypeClasses -XTypeSynonymInstances #-}------------------------------------------------------------------------------------ Module : IDE.Pane.References--- Copyright : (c) Juergen Nicklisch-Franken, Hamish Mackenzie--- License : GNU-GPL------ Maintainer : <maintainer at leksah.org>--- Stability : provisional--- Portability : portable------ | The pane of the ide where references to an identifier are presented-------------------------------------------------------------------------------------module IDE.Pane.References (- ReferencesState-, IDEReferences-, referencedFrom-, getReferences-) where--import Graphics.UI.Gtk hiding (get)-import IDE.Find (focusFindEntry,showFindbar,setFindState,entryStr, getFindState, editFind)-import IDE.Pane.SourceBuffer (selectSourceBuf)-import Graphics.UI.Gtk.Gdk.Events-import Data.IORef (newIORef,writeIORef,readIORef,IORef(..))-import Data.Maybe-import Control.Monad.Reader-import qualified Data.Map as Map-import qualified Data.Set as Set-import Data.List-import Data.Typeable-import Distribution.ModuleName(ModuleName)-import Distribution.Text-import Text.PrettyPrint (render)-import IDE.Core.State-import IDE.Metainfo.Provider- (getSystemInfo, getWorkspaceInfo, getPackageInfo)----- | A References pane description-----data IDEReferences = IDEReferences {- scrolledView :: ScrolledWindow-, treeViewC :: TreeView-, referencesDescr :: IORef (Maybe Descr)-, referencesStore :: ListStore (ModuleDescr,String)-, refScopeRef :: IORef Scope-, referencesEntry :: Entry-, topBox :: VBox-} deriving Typeable--data ReferencesState = ReferencesState {- refTo :: Maybe Descr-, refScope :: Scope}- deriving(Eq,Ord,Read,Show,Typeable)--instance Pane IDEReferences IDEM- where- primPaneName _ = "References"- getAddedIndex _ = 0- getTopWidget = castToWidget . topBox- paneId b = "*References"---- |-instance RecoverablePane IDEReferences ReferencesState IDEM where- saveState p = do- mbDescr <- liftIO $ readIORef (referencesDescr p)- scope <- liftIO $ readIORef (refScopeRef p)- return (Just (ReferencesState mbDescr scope))- recoverState pp (ReferencesState mbDescr scope) = do- nb <- getNotebook pp- p <- buildPane pp nb builder- scopeSelection scope- when (isJust mbDescr) (referencedFrom (fromJust mbDescr))- return p- builder pp nb windows = reifyIDE $ \ ideR -> do- scopebox <- hBoxNew True 2- rb1 <- radioButtonNewWithLabel "Package"- rb2 <- radioButtonNewWithLabelFromWidget rb1 "Workspace"- rb3 <- radioButtonNewWithLabelFromWidget rb1 "System"- toggleButtonSetActive rb3 True- cb2 <- checkButtonNewWithLabel "Imports"-- boxPackStart scopebox rb1 PackGrow 2- boxPackStart scopebox rb2 PackGrow 2- boxPackStart scopebox rb3 PackGrow 2- boxPackEnd scopebox cb2 PackNatural 2-- listStore <- listStoreNew []- treeView <- treeViewNew- treeViewSetModel treeView listStore-- renderer0 <- cellRendererPixbufNew- set renderer0 [ cellPixbufStockId := stockYes ]-- renderer <- cellRendererTextNew- col <- treeViewColumnNew- treeViewColumnSetTitle col "Modules"- treeViewColumnSetSizing col TreeViewColumnAutosize- treeViewColumnSetResizable col True- treeViewColumnSetReorderable col True- treeViewAppendColumn treeView col- cellLayoutPackStart col renderer0 False- cellLayoutPackStart col renderer True- cellLayoutSetAttributes col renderer listStore- $ \row -> [ cellText := render $ disp $ modu $ mdModuleId $ fst row]- cellLayoutSetAttributes col renderer0 listStore- $ \row -> [cellPixbufStockId :=- if isJust (mdMbSourcePath $ fst row)- then stockJumpTo- else stockYes]-- renderer2 <- cellRendererTextNew- col2 <- treeViewColumnNew- treeViewColumnSetTitle col2 "Packages"- treeViewColumnSetSizing col2 TreeViewColumnAutosize- treeViewColumnSetResizable col True- treeViewColumnSetReorderable col2 True- treeViewAppendColumn treeView col2- cellLayoutPackStart col2 renderer2 True- cellLayoutSetAttributes col2 renderer2 listStore- $ \row -> [ cellText := render $ disp $ pack $ mdModuleId $ fst row]-- treeViewSetHeadersVisible treeView True- sel <- treeViewGetSelection treeView- treeSelectionSetMode sel SelectionSingle-- sw <- scrolledWindowNew Nothing Nothing- containerAdd sw treeView- scrolledWindowSetPolicy sw PolicyAutomatic PolicyAutomatic- entry <- entryNew- set entry [ entryEditable := False ]- box <- vBoxNew False 2- boxPackStart box scopebox PackNatural 0- boxPackStart box entry PackNatural 0- boxPackEnd box sw PackGrow 0- referencesDescr' <- newIORef Nothing- scopeRef <- newIORef SystemScope- 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' rb1 rb2 rb3 cb2) ideR )- rb2 `onToggled` (reflectIDE (scopeSelection' rb1 rb2 rb3 cb2) ideR )- rb3 `onToggled` (reflectIDE (scopeSelection' rb1 rb2 rb3 cb2) ideR )- cb2 `onToggled` (reflectIDE (scopeSelection' rb1 rb2 rb3 cb2) ideR)- return (Just references,[ConnectC cid1])--getReferences :: Maybe PanePath -> IDEM IDEReferences-getReferences Nothing = forceGetPane (Right "*References")-getReferences (Just pp) = forceGetPane (Left pp)----- | Open a pane with the references of this identifier-referencedFrom :: Descr -> IDEAction-referencedFrom idDescr =- case dsMbModu idDescr of- Nothing -> return ()- Just pm -> do- references <- getReferences Nothing- scope <- liftIO $ getScope references- mbPackageInfo <- getPackageInfo- mbWorkspaceInfo <- getWorkspaceInfo- mbSystemInfo <- getSystemInfo- let packages = packagesFromScope scope mbPackageInfo mbWorkspaceInfo mbSystemInfo- let modulesList = modulesForCallerFromPackages packages (dscName idDescr, modu pm)- liftIO $ do- writeIORef (referencesDescr references) (Just idDescr)- listStoreClear (referencesStore references)- mapM_ (listStoreAppend (referencesStore references))- $ sort $ zip modulesList (repeat (dscName idDescr))- entrySetText (referencesEntry references)- $ dscName idDescr ++- " << " ++ showPackModule pm- bringPaneToFront references--packagesFromScope SystemScope- _- (Just (_,GenScopeC (PackScope p1 _)))- (Just (GenScopeC (PackScope p2 _))) = Map.elems p1 ++ Map.elems p2-packagesFromScope SystemScope- _- (Just (GenScopeC (PackScope p1 _),GenScopeC (PackScope p2 _)))- _ = Map.elems p1 ++ Map.elems p2-packagesFromScope (WorkspaceScope True)- _- (Just (GenScopeC (PackScope p1 _),GenScopeC (PackScope p2 _)))- _ = Map.elems p1 ++ Map.elems p2-packagesFromScope (WorkspaceScope False)- _- (Just (GenScopeC (PackScope p1 _),_))- _ = Map.elems p1-packagesFromScope (PackageScope True)- (Just (GenScopeC (PackScope p1 _),GenScopeC (PackScope p2 _)))- _- _ = Map.elems p1 ++ Map.elems p2-packagesFromScope (PackageScope False)- (Just (GenScopeC (PackScope p1 _),_))- _- _ = Map.elems p1-packagesFromScope _ _ _ _ = []--modulesForCallerFromPackages :: [PackageDescr] -> (String,ModuleName) -> [ModuleDescr]-modulesForCallerFromPackages [] _ = []-modulesForCallerFromPackages (p :rest) (sym,mod) =- (filter (\ md -> case mod `Map.lookup` (mdReferences md) of- Nothing -> False- Just syms -> sym `Set.member` syms) (pdModules p))- ++ modulesForCallerFromPackages rest (sym,mod)--scopeSelection' rb1 rb2 rb3 cb2 = do- scope <- liftIO $ do- withImports <- toggleButtonGetActive cb2- s1 <- toggleButtonGetActive rb1- s2 <- toggleButtonGetActive rb2- s3 <- toggleButtonGetActive rb3- if s1- then return (PackageScope withImports)- else if s2- then return (WorkspaceScope withImports)- else return (SystemScope)- scopeSelection scope--scopeSelection :: Scope -> IDEAction-scopeSelection scope = do- refs <- getReferences Nothing- liftIO $ writeIORef (refScopeRef refs) scope- mbDescr <- liftIO $ readIORef (referencesDescr refs)- case mbDescr of- Nothing -> return ()- Just descr -> referencedFrom descr--getScope :: IDEReferences -> IO Scope-getScope refs = readIORef (refScopeRef refs)---getSelectionTree :: TreeView- -> ListStore (ModuleDescr,String)- -> IO (Maybe (ModuleDescr,String))-getSelectionTree treeView listStore = do- treeSelection <- treeViewGetSelection treeView- rows <- treeSelectionGetSelectedRows treeSelection- case rows of- [[n]] -> do- val <- listStoreGetValue listStore n- return (Just val)- _ -> return Nothing--treeViewPopup :: IDERef- -> IDEReferences- -> Event- -> IO (Bool)-treeViewPopup ideR references (Button _ click _ _ _ _ button _ _) = do- if button == RightButton- then do- theMenu <- menuNew- item1 <- menuItemNewWithLabel "Edit"- item1 `onActivateLeaf` do- sel <- getSelectionTree (treeViewC references) (referencesStore references)- case sel of- Just (m,_) -> case mdMbSourcePath m of- Nothing -> return ()- Just fp -> do- text <- entryGetText (referencesEntry references)- case words text of- (hd : tl) -> do- reflectIDE (selectText fp hd) ideR- return ()- _ -> return ()- otherwise -> return ()- menuShellAppend theMenu item1- menuPopup theMenu Nothing- widgetShowAll theMenu- return True- else if button == LeftButton && click == DoubleClick- then do sel <- getSelectionTree (treeViewC references)- (referencesStore references)- case sel of- Just (m,_)- -> case mdMbSourcePath m of- Nothing -> return False- Just fp -> do- text <- entryGetText (referencesEntry references)- case words text of- (hd : tl) -> do- reflectIDE (selectText fp hd) ideR- return True- _ -> return False- otherwise -> return False- else return False-treeViewPopup _ _ _ = throwIDE "treeViewPopup wrong event type"--selectText :: FilePath -> String -> IDEM Bool-selectText fp text = do- res <- selectSourceBuf fp- fs <- getFindState- case res of- Nothing -> return False- Just _ -> do- setFindState fs {entryStr = text}- showFindbar- focusFindEntry- reifyIDE $ \ideR -> do- idleAdd (do- reflectIDE (editFind True True True False text "" Forward) ideR- return False)- priorityDefaultIdle- return True--
src/IDE/Pane/SourceBuffer.hs view
@@ -1,5 +1,5 @@ {-# OPTIONS_GHC -XDeriveDataTypeable -XMultiParamTypeClasses -XTypeSynonymInstances- -XScopedTypeVariables #-}+ -XScopedTypeVariables -XRankNTypes #-} ----------------------------------------------------------------------------- -- -- Module : IDE.Pane.SourceBuffer@@ -94,28 +94,28 @@ import IDE.TextEditor import qualified System.IO.UTF8 as UTF8 import Data.IORef (writeIORef,readIORef,newIORef,IORef(..))-import Data.Char (isAlphaNum)+import Data.Char (isAlphaNum, isSymbol) import Control.Event (triggerEvent) import IDE.Metainfo.Provider (getSystemInfo, getWorkspaceInfo) import Distribution.Text (simpleParse) import Distribution.ModuleName (ModuleName) import qualified Data.Set as Set (member)-import Graphics.UI.Gtk.Gdk.Events as Gtk import Graphics.UI.Gtk- (Notebook, clipboardGet, atomNew, dialogAddButton, widgetDestroy,+ (Notebook, clipboardGet, selectionClipboard, dialogAddButton, widgetDestroy, fileChooserGetFilename, widgetShow, fileChooserDialogNew, notebookGetNthPage, notebookPageNum, widgetHide, dialogRun, messageDialogNew, postGUIAsync, scrolledWindowSetShadowType,- scrolledWindowSetPolicy, castToWidget, ScrolledWindow)+ scrolledWindowSetPolicy, castToWidget, ScrolledWindow, dialogSetDefaultResponse,+ fileChooserSetCurrentFolder, fileChooserSelectFilename) import System.Glib.MainLoop (priorityDefaultIdle, idleAdd) #if MIN_VERSION_gtk(0,10,5)-import Graphics.UI.Gtk (Underline(..))+import Graphics.UI.Gtk (windowWindowPosition, Underline(..)) #else import Graphics.UI.Gtk.Pango.Types (Underline(..)) #endif import qualified Graphics.UI.Gtk as Gtk (Window, Notebook) import Graphics.UI.Gtk.General.Enums- (ShadowType(..), PolicyType(..))+ (WindowPosition(..), ShadowType(..), PolicyType(..)) import Graphics.UI.Gtk.Windows.MessageDialog (ButtonsType(..), MessageType(..)) #if MIN_VERSION_gtk(0,10,5)@@ -125,30 +125,11 @@ #endif import Graphics.UI.Gtk.Selectors.FileChooser (FileChooserAction(..))-------- | A text editor pane description----data IDEBuffer = IDEBuffer {- fileName :: Maybe FilePath-, bufferName :: String-, addedIndex :: Int-, sourceView :: EditorView-, scrolledWindow :: ScrolledWindow-, modTime :: IORef (Maybe (ClockTime))-} deriving (Typeable)--data BufferState = BufferState FilePath Int- | BufferStateTrans String String Int- deriving(Eq,Ord,Read,Show,Typeable)+import System.Glib.Attributes (AttrOp(..), set)+import IDE.BufferMode -instance Pane IDEBuffer IDEM- where- primPaneName = bufferName- getAddedIndex = addedIndex- getTopWidget = castToWidget . scrolledWindow- paneId b = ""+allBuffers :: IDEM [IDEBuffer]+allBuffers = getPanes instance RecoverablePane IDEBuffer BufferState IDEM where saveState p = do buf <- getBuffer (sourceView p)@@ -177,18 +158,17 @@ Nothing -> return Nothing recoverState pp (BufferStateTrans bn text i) = do mbbuf <- newTextBuffer pp bn Nothing- useCandy <- getCandyState case mbbuf of Just buf -> do- candy' <- readIDE candy- gtkBuf <- getBuffer (sourceView buf)+ useCandy <- useCandyFor buf+ candy' <- readIDE candy+ gtkBuf <- getBuffer (sourceView buf) setText gtkBuf text- when useCandy $ transformToCandy candy' gtkBuf- iter <- getIterAtOffset gtkBuf i+ iter <- getIterAtOffset gtkBuf i placeCursor gtkBuf iter- mark <- getInsertMark gtkBuf- ideR <- ask+ mark <- getInsertMark gtkBuf+ ideR <- ask liftIO $ idleAdd (do reflectIDE (scrollToMark (sourceView buf) mark 0.0 (Just (0.3,0.3))) ideR return False) priorityDefaultIdle@@ -213,8 +193,6 @@ buildPane panePath notebook builder = return Nothing builder pp nb w = return (Nothing,[]) -- startComplete :: IDEAction startComplete = do mbBuf <- maybeActiveBuf@@ -225,7 +203,7 @@ selectSourceBuf :: FilePath -> IDEM (Maybe IDEBuffer) selectSourceBuf fp = do- fpc <- liftIO $ canonicalizePath fp+ fpc <- liftIO $ myCanonicalizePath fp buffers <- allBuffers let buf = filter (\b -> case fileName b of Just fn -> equalFilePath fn fpc@@ -242,20 +220,9 @@ pp <- getBestPathForId "*Buffer" nbuf <- newTextBuffer pp (takeFileName fpc) (Just fpc) return nbuf- else return Nothing--recentSourceBuffers :: IDEM [PaneName]-recentSourceBuffers = do- recentPanes' <- readIDE recentPanes- mbBufs <- mapM mbPaneFromName recentPanes'- 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+ else do+ ideMessage Normal ("File path not found " ++ fpc)+ return Nothing goToDefinition :: Descr -> IDEAction goToDefinition idDescr = do@@ -287,6 +254,7 @@ goToSourceDefinition :: FilePath -> Maybe Location -> IDEAction goToSourceDefinition fp dscMbLocation = do+ liftIO $ putStrLn $ "goToSourceDefinition " ++ fp mbBuf <- selectSourceBuf fp when (isJust mbBuf && isJust dscMbLocation) $ inActiveBufContext () $ \_ ebuf buf _ -> do@@ -328,7 +296,7 @@ markRefInSourceBuf :: Int -> IDEBuffer -> LogRef -> Bool -> IDEAction markRefInSourceBuf index buf logRef scrollTo = do- useCandy <- getCandyState+ useCandy <- useCandyFor buf candy' <- readIDE candy contextRefs <- readIDE contextRefs prefs <- readIDE prefs@@ -396,20 +364,6 @@ return False) priorityDefaultIdle return () -allBuffers :: IDEM [IDEBuffer]-allBuffers = getPanes--maybeActiveBuf :: IDEM (Maybe IDEBuffer)-maybeActiveBuf = do- mbActivePane <- getActivePane- mbPane <- lastActiveBufferPane- case (mbPane,mbActivePane) of- (Just paneName1, Just (paneName2,_)) | paneName1 == paneName2 -> do- (PaneC pane) <- paneFromName paneName1- let mbActbuf = cast pane- return mbActbuf- _ -> return Nothing- newTextBuffer :: PanePath -> String -> Maybe FilePath -> IDEM (Maybe IDEBuffer) newTextBuffer panePath bn mbfn = do cont <- case mbfn of@@ -454,7 +408,8 @@ background foundTag $ foundBackground prefs beginNotUndoableAction buffer- when bs $ transformToCandy ct buffer+ let mod = modFromFileName mbfn+ when (bs && isHaskellMode mod) $ transformToCandy ct buffer endNotUndoableAction buffer setModified buffer False siter <- getStartIter buffer@@ -464,17 +419,30 @@ -- create a new SourceView Widget sv <- newView buffer (textviewFont prefs) setShowLineNumbers sv $ showLineNumbers prefs- setRightMargin sv $ rightMargin prefs+ setRightMargin sv $ case rightMargin prefs of+ (False,_) -> Nothing+ (True,v) -> Just v setIndentWidth sv $ tabWidth prefs setTabWidth sv $ tabWidth prefs- setStyle buffer $ sourceStyle prefs+ setStyle buffer $ case sourceStyle prefs of+ (False,_) -> Nothing+ (True,v) -> Just v -- put it in a scrolled window sw <- getScrolledWindow sv- liftIO $ scrolledWindowSetPolicy sw PolicyAutomatic PolicyAutomatic+ if wrapLines prefs+ then liftIO $ scrolledWindowSetPolicy sw PolicyNever PolicyAutomatic+ else liftIO $ scrolledWindowSetPolicy sw PolicyAutomatic PolicyAutomatic liftIO $ scrolledWindowSetShadowType sw ShadowIn modTimeRef <- liftIO $ newIORef modTime- let buf = IDEBuffer mbfn bn ind sv sw modTimeRef+ let buf = IDEBuffer {+ fileName = mbfn,+ bufferName = bn,+ addedIndex = ind,+ sourceView =sv,+ scrolledWindow = sw,+ modTime = modTimeRef,+ mode = mod} -- events ids1 <- sv `afterFocusIn` makeActive buf ids2 <- onCompletion sv (Completion.complete sv False) Completion.cancel@@ -484,10 +452,17 @@ liftIO $ reflectIDE (do case click of DoubleClick -> do- let isSelectChar a = (isAlphaNum a) || (a == '_')+ let isIdent a = isAlphaNum a || a == '\'' || a == '_'+ let isOp a = isSymbol a || a == ':' || a == '\\' || a == '*' || a == '/' || a == '-'+ || a == '!' || a == '@' || a == '%' || a == '&' || a == '?' (startSel, endSel) <- getSelectionBounds buffer mbStartChar <- getChar startSel mbEndChar <- getChar endSel+ let isSelectChar =+ case mbStartChar of+ Just startChar | isIdent startChar -> isIdent+ Just startChar | isOp startChar -> isOp+ _ -> const False start <- case mbStartChar of Just startChar | isSelectChar startChar -> do maybeIter <- backwardFindCharC startSel (not.isSelectChar) Nothing@@ -514,20 +489,20 @@ return (Just buf,concat [ids1, ids2, ids3, ids4]) -checkModTime :: IDEBuffer -> IDEM Bool+checkModTime :: IDEBuffer -> IDEM (Bool, Bool) checkModTime buf = do currentState' <- readIDE currentState case currentState' of- IsShuttingDown -> return False- _ -> reifyIDE (\ideR -> do+ IsShuttingDown -> return (False, False)+ _ -> do let name = paneName buf case fileName buf of Just fn -> do- exists <- doesFileExist fn+ exists <- liftIO $ doesFileExist fn if exists then do- nmt <- getModificationTime fn- modTime' <- readIORef (modTime buf)+ nmt <- liftIO $ getModificationTime fn+ modTime' <- liftIO $ readIORef (modTime buf) case modTime' of Nothing -> error $"checkModTime: time not set " ++ show (fileName buf) Just mt ->@@ -538,25 +513,44 @@ -- Praises to whoever finds out what happens and how to fix this #endif then do+ load <- readIDE (autoLoad . prefs)+ if load+ then do+ ideMessage Normal $ "Auto Loading " ++ fn+ revert buf+ return (False, True)+ else do+ window <- getMainWindow+ resp <- liftIO $ do md <- messageDialogNew- Nothing []+ (Just window) [] MessageQuestion- ButtonsYesNo- ("File \"" ++ name ++ "\" has changed on disk. Load file from disk?")+ ButtonsNone+ ("File \"" ++ name ++ "\" has changed on disk.")+ dialogAddButton md "_Load From Disk" (ResponseUser 1)+ dialogAddButton md "_Always Load From Disk" (ResponseUser 2)+ dialogAddButton md "_Don't Load" (ResponseUser 3)+ dialogSetDefaultResponse md (ResponseUser 1)+ set md [ windowWindowPosition := WinPosCenterOnParent ] 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)+ widgetDestroy md+ return resp+ case resp of+ ResponseUser 1 -> do+ revert buf+ return (False, True)+ ResponseUser 2 -> do+ revert buf+ modifyIDE_ $ \ide -> ide{prefs = (prefs ide) {autoLoad = True}}+ return (False, True)+ ResponseUser 3 -> do+ nmt2 <- liftIO $ getModificationTime fn+ liftIO $ writeIORef (modTime buf) (Just nmt2)+ return (True, True)+ _ -> do return (False, False)+ else return (False, False)+ else return (False, False)+ Nothing -> return (False, False) setModTime :: IDEBuffer -> IDEAction setModTime buf = do@@ -573,7 +567,7 @@ revert :: IDEBuffer -> IDEAction revert buf = do- useCandy <- getCandyState+ useCandy <- useCandyFor buf ct <- readIDE candy let name = paneName buf case fileName buf of@@ -635,33 +629,12 @@ modified <- getModified ebuf liftIO $ markLabel nb (getTopWidget buf) modified -inBufContext :: alpha -> IDEBuffer -> (Notebook -> EditorBuffer -> IDEBuffer -> Int -> IDEM alpha) -> IDEM alpha-inBufContext def ideBuf f = do- (pane,_) <- guiPropertiesFromName (paneName ideBuf)- nb <- getNotebook pane- mbI <- liftIO $notebookPageNum nb (scrolledWindow ideBuf)- case mbI of- Nothing -> liftIO $ do- sysMessage Normal $ bufferName ideBuf ++ " notebook page not found: unexpected"- return def- Just i -> do- ebuf <- getBuffer (sourceView ideBuf)- f nb ebuf ideBuf i--inActiveBufContext :: alpha -> (Notebook -> EditorBuffer -> IDEBuffer -> Int -> IDEM alpha) -> IDEM alpha-inActiveBufContext def f = do- mbBuf <- maybeActiveBuf- case mbBuf of- Nothing -> return def- Just ideBuf -> do- inBufContext def ideBuf f- fileSaveBuffer :: Bool -> Notebook -> EditorBuffer -> IDEBuffer -> Int -> IDEM Bool fileSaveBuffer query nb ebuf ideBuf i = do ideR <- ask window <- getMainWindow prefs <- readIDE prefs- bs <- getCandyState+ useCandy <- useCandyFor ideBuf candy <- readIDE candy (panePath,connects) <- guiPropertiesFromName (paneName ideBuf) let mbfn = fileName ideBuf@@ -670,14 +643,15 @@ Nothing -> throwIDE "fileSave: Page not found" Just page -> if isJust mbfn && query == False- then do modifiedOnDisk <- checkModTime ideBuf -- The user is given option to reload+ then do (modifiedOnDiskNotLoaded, modifiedOnDisk) <- checkModTime ideBuf -- The user is given option to reload modifiedInBuffer <- getModified ebuf- if (modifiedOnDisk || modifiedInBuffer)+ if (modifiedOnDiskNotLoaded || modifiedInBuffer) then do- fileSave' (forceLineEnds prefs) (removeTBlanks prefs) nb ideBuf bs candy $fromJust mbfn+ fileSave' (forceLineEnds prefs) (removeTBlanks prefs) nb ideBuf+ useCandy candy $fromJust mbfn setModTime ideBuf return True- else return False+ else return modifiedOnDisk else reifyIDE $ \ideR -> do dialog <- fileChooserDialogNew (Just $ "Save File")@@ -687,6 +661,9 @@ ,ResponseCancel) --you can use stock buttons ,("gtk-save" , ResponseAccept)]+ case mbfn of+ Just fn -> fileChooserSelectFilename dialog fn >> return ()+ Nothing -> return () widgetShow dialog response <- dialogRun dialog mbFileName <- case response of@@ -702,29 +679,31 @@ resp <- if dfe then do md <- messageDialogNew (Just window) [] MessageQuestion- ButtonsYesNo- "File already exist. Overwrite?"+ ButtonsCancel+ "File already exist."+ dialogAddButton md "_Overwrite" ResponseYes+ dialogSetDefaultResponse md ResponseCancel+ set md [ windowWindowPosition := WinPosCenterOnParent ] resp <- dialogRun md widgetHide md return resp else return ResponseYes case resp of ResponseYes -> do- cfn <- canonicalizePath fn- reflectIDE (do- fileSave' (forceLineEnds prefs) (removeTBlanks prefs) nb ideBuf bs candy cfn+ fileSave' (forceLineEnds prefs) (removeTBlanks prefs)+ nb ideBuf useCandy candy fn closePane ideBuf- newTextBuffer panePath (takeFileName fn) (Just cfn)- ) ideR+ cfn <- liftIO $ myCanonicalizePath fn+ newTextBuffer panePath (takeFileName cfn) (Just cfn)+ ) ideR return True- ResponseNo -> return False _ -> return False where fileSave' :: Bool -> Bool -> Notebook -> IDEBuffer -> Bool -> CandyTable -> FilePath -> IDEAction- fileSave' forceLineEnds removeTBlanks nb ideBuf bs ct fn = do+ fileSave' forceLineEnds removeTBlanks nb ideBuf useCandy candyTable fn = do buf <- getBuffer $ sourceView ideBuf- text <- getCandylessText ct buf+ text <- getCandylessText candyTable buf let text' = if removeTBlanks then unlines $ map removeTrailingBlanks $lines text else text@@ -751,7 +730,7 @@ fileCheckBuffer nb ebuf ideBuf i = do let mbfn = fileName ideBuf if isJust mbfn- then do modifiedOnDisk <- checkModTime ideBuf -- The user is given option to reload+ then do (_, modifiedOnDisk) <- checkModTime ideBuf -- The user is given option to reload modifiedInBuffer <- getModified ebuf return (modifiedOnDisk || modifiedInBuffer) else return False@@ -788,13 +767,13 @@ then do md <- messageDialogNew (Just window) [] MessageQuestion- ButtonsNone+ ButtonsCancel ("Save changes to document: " ++ paneName currentBuffer ++ "?") dialogAddButton md "_Save" ResponseYes dialogAddButton md "_Don't Save" ResponseNo- dialogAddButton md "_Cancel" ResponseCancel+ set md [ windowWindowPosition := WinPosCenterOnParent ] resp <- dialogRun md widgetDestroy md case resp of@@ -875,6 +854,7 @@ fileOpen = do window <- getMainWindow prefs <- readIDE prefs+ mbBuf <- maybeActiveBuf mbFileName <- liftIO $ do dialog <- fileChooserDialogNew (Just $ "Open File")@@ -884,6 +864,9 @@ ,ResponseCancel) ,("gtk-open" ,ResponseAccept)]+ case mbBuf >>= fileName of+ Just fn -> fileChooserSetCurrentFolder dialog (dropFileName $ fn) >> return ()+ Nothing -> return () widgetShow dialog response <- dialogRun dialog case response of@@ -906,24 +889,30 @@ fileOpenThis :: FilePath -> IDEAction fileOpenThis fp = do prefs <- readIDE prefs- fpc <- liftIO $canonicalizePath fp+ fpc <- liftIO $ myCanonicalizePath fp buffers <- allBuffers let buf = filter (\b -> case fileName b of Just fn -> equalFilePath fn fpc Nothing -> False) buffers case buf of hdb:tl -> do- md <- liftIO $messageDialogNew- Nothing []- MessageQuestion- ButtonsYesNo- ("Buffer already open. " ++- "Make active instead of opening a second time?")- resp <- liftIO $dialogRun md- liftIO $ widgetDestroy md+ window <- getMainWindow+ resp <- liftIO $ do+ md <- messageDialogNew+ (Just window) []+ MessageQuestion+ ButtonsNone+ "Buffer already open."+ dialogAddButton md "Make _Active" (ResponseUser 1)+ dialogAddButton md "_Open Second" (ResponseUser 2)+ dialogSetDefaultResponse md (ResponseUser 1)+ set md [ windowWindowPosition := WinPosCenterOnParent ]+ resp <- dialogRun md+ widgetDestroy md+ return resp case resp of- ResponseNo -> reallyOpen prefs fpc- _ -> makeActive hdb+ ResponseUser 2 -> reallyOpen prefs fpc+ _ -> makeActive hdb [] -> reallyOpen prefs fpc where reallyOpen prefs fpc = do@@ -954,62 +943,21 @@ editCut :: IDEAction editCut = inActiveBufContext () $ \_ ebuf _ _ -> do- cb <- liftIO $ atomNew "GDK_SELECTION_CLIPBOARD"- clip <- liftIO $ clipboardGet cb+ clip <- liftIO $ clipboardGet selectionClipboard cutClipboard ebuf clip True editCopy :: IDEAction editCopy = inActiveBufContext () $ \_ ebuf _ _ -> do- cb <- liftIO $ atomNew "GDK_SELECTION_CLIPBOARD"- clip <- liftIO $ clipboardGet cb+ clip <- liftIO $ clipboardGet selectionClipboard copyClipboard ebuf clip editPaste :: IDEAction editPaste = inActiveBufContext () $ \_ ebuf _ _ -> do- cb <- liftIO $ atomNew "GDK_SELECTION_CLIPBOARD" mark <- getInsertMark ebuf iter <- getIterAtMark ebuf mark- clip <- liftIO $ clipboardGet cb+ clip <- liftIO $ clipboardGet selectionClipboard pasteClipboard ebuf clip iter True -getStartAndEndLineOfSelection :: EditorBuffer -> IDEM (Int,Int)-getStartAndEndLineOfSelection ebuf = do- startMark <- getInsertMark ebuf- endMark <- getSelectionBoundMark ebuf- startIter <- getIterAtMark ebuf startMark- endIter <- getIterAtMark ebuf endMark- startLine <- getLine startIter- endLine <- getLine endIter- let (startLine',endLine',endIter') = if endLine >= startLine- then (startLine,endLine,endIter)- else (endLine,startLine,startIter)- b <- startsLine endIter'- let endLineReal = if b && endLine /= startLine then endLine' - 1 else endLine'- return (startLine',endLineReal)--doForSelectedLines :: [a] -> (EditorBuffer -> Int -> IDEM a) -> IDEM [a]-doForSelectedLines d f = inActiveBufContext d $ \_ ebuf currentBuffer _ -> do- (start,end) <- getStartAndEndLineOfSelection ebuf- mapM (f ebuf) [start .. end]--editComment :: IDEAction-editComment = do- doForSelectedLines [] $ \ebuf lineNr -> do- sol <- getIterAtLine ebuf lineNr- insert ebuf sol "--"- return ()--editUncomment :: IDEAction-editUncomment = do- doForSelectedLines [] $ \ebuf lineNr -> do- sol <- getIterAtLine ebuf lineNr- sol2 <- forwardCharsC sol 2- str <- getText ebuf sol sol2 True- if str == "--"- then do delete ebuf sol sol2- else return ()- return ()- editShiftLeft :: IDEAction editShiftLeft = do prefs <- readIDE prefs@@ -1042,34 +990,6 @@ insert ebuf sol str return () -editToCandy :: IDEAction-editToCandy = do- ct <- readIDE candy- inActiveBufContext () $ \_ ebuf _ _ -> do- transformToCandy ct ebuf--editFromCandy :: IDEAction-editFromCandy = do- ct <- readIDE candy- inActiveBufContext () $ \_ ebuf _ _ -> do- transformFromCandy ct ebuf--editKeystrokeCandy :: Maybe Char -> IDEAction-editKeystrokeCandy c = do- ct <- readIDE candy- inActiveBufContext () $ \_ ebuf _ _ -> do- keystrokeCandy ct c ebuf--editCandy :: IDEAction-editCandy = do- ct <- readIDE candy- buffers <- allBuffers- gtkbufs <- mapM (\ b -> getBuffer (sourceView b)) buffers- bs <- getCandyState- if bs- then mapM_ (transformToCandy ct) gtkbufs- else mapM_ (transformFromCandy ct) gtkbufs- alignChar :: Char -> IDEAction alignChar char = do positions <- positionsOfChar@@ -1153,9 +1073,9 @@ selectedLocation :: IDEM (Maybe (Int, Int)) selectedLocation = do- useCandy <- getCandyState candy' <- readIDE candy inActiveBufContext Nothing $ \_ ebuf currentBuffer _ -> do+ useCandy <- useCandyFor currentBuffer (start, _) <- getSelectionBounds ebuf line <- getLine start lineOffset <- getLineOffset start@@ -1164,13 +1084,11 @@ else return (line, lineOffset) return $ Just res --- " ++ ++ ++ alpha- insertTextAfterSelection :: String -> IDEAction insertTextAfterSelection str = do- candy' <- readIDE candy- useCandy <- getCandyState- inActiveBufContext () $ \_ ebuf currentBuffer _ -> do+ candy' <- readIDE candy+ inActiveBufContext () $ \_ ebuf currentBuffer _ -> do+ useCandy <- useCandyFor currentBuffer hasSelection <- hasSelection ebuf when hasSelection $ do realString <- if useCandy then stringToCandy candy' str else return str@@ -1181,18 +1099,11 @@ i2 <- forwardCharsC i1 (length str) selectRange ebuf i1 i2 -selectedModuleName :: IDEM (Maybe String)-selectedModuleName = do- candy' <- readIDE candy- inActiveBufContext Nothing $ \_ ebuf currentBuffer _ -> do- case fileName currentBuffer of- Just filePath -> liftIO $ moduleNameFromFilePath filePath- Nothing -> return Nothing- -- | Returns the package, to which this buffer belongs, if possible belongsToPackage :: IDEBuffer -> IDEM(Maybe IDEPackage)-belongsToPackage ideBuf | fileName ideBuf == Nothing = return Nothing- | otherwise = do+belongsToPackage ideBuf | fileName ideBuf == Nothing = return Nothing+ | not (isHaskellMode (mode ideBuf)) = return Nothing+ | otherwise = do bufferToProject' <- readIDE bufferProjCache ws <- readIDE workspace let fp = fromJust (fileName ideBuf)@@ -1227,3 +1138,15 @@ else Nothing belongsToWorkspace b = belongsToPackage b >>= return . isJust++useCandyFor :: IDEBuffer -> IDEM Bool+useCandyFor aBuffer = do+ use <- getCandyState+ return (use && isHaskellMode (mode aBuffer))++editCandy = do+ use <- getCandyState+ buffers <- allBuffers+ if use+ then mapM_ (modeEditToCandy . mode) buffers+ else mapM_ (modeEditFromCandy . mode) buffers
src/IDE/Pane/Trace.hs view
@@ -24,6 +24,7 @@ import Data.Typeable (Typeable(..)) import IDE.Core.State import Control.Monad.Reader+import IDE.Package (tryDebug_) import IDE.Debug (debugForward, debugBack, debugCommand') import IDE.Utils.Tool (ToolOutput(..))@@ -46,7 +47,7 @@ import Graphics.UI.Gtk.Gdk.Events (Event(..)) import Graphics.UI.Gtk.General.Enums (MouseButton(..)) import System.Log.Logger (debugM)-+import IDE.Workspaces (packageTry_) -- | A debugger pane description --@@ -155,12 +156,12 @@ return (Just pane,[ConnectC cid1]) fillTraceList :: IDEAction-fillTraceList = do- currentHist' <- readIDE currentHist- mbTraces <- getPane+fillTraceList = packageTry_ $ do+ currentHist' <- lift $ readIDE currentHist+ mbTraces <- lift getPane case mbTraces of Nothing -> return ()- Just tracePane -> debugCommand' ":history" (\to -> liftIO $ postGUIAsync $ do+ Just tracePane -> tryDebug_ $ debugCommand' ":history" (\to -> liftIO $ postGUIAsync $ do let parseRes = parse tracesParser "" (selectString to) r <- case parseRes of Left err -> do
src/IDE/Pane/Variables.hs view
@@ -24,6 +24,7 @@ import Data.Typeable (Typeable(..)) import IDE.Core.State import Control.Monad.Reader+import IDE.Package (tryDebug_) import IDE.Debug (debugCommand') import IDE.Utils.Tool (ToolOutput(..)) import Text.ParserCombinators.Parsec@@ -44,6 +45,7 @@ import Graphics.UI.Gtk.Gdk.Events (Event(..)) import Graphics.UI.Gtk.General.Enums (Click(..), MouseButton(..))+import IDE.Workspaces (packageTry_) -- | A variables pane description --@@ -135,11 +137,11 @@ fillVariablesList :: IDEAction-fillVariablesList = do- mbVariables <- getPane+fillVariablesList = packageTry_ $ do+ mbVariables <- lift getPane case mbVariables of Nothing -> return ()- Just var -> debugCommand' ":show bindings" (\to -> liftIO $ postGUIAsync+ Just var -> tryDebug_ $ debugCommand' ":show bindings" (\to -> liftIO $ postGUIAsync $ (do case parse variablesParser "" (selectString to) of Left e -> sysMessage Normal (show e)@@ -255,7 +257,7 @@ variablesViewPopup _ _ _ _ = throwIDE "variablesViewPopup wrong event type" forceVariable :: VarDescription -> TreePath -> TreeStore VarDescription -> IDEAction-forceVariable varDescr path treeStore = do+forceVariable varDescr path treeStore = packageTry_ $ tryDebug_ $ do debugCommand' (":force " ++ (varName varDescr)) (\to -> liftIO $ postGUIAsync (do case parse valueParser "" (selectString to) of Left e -> sysMessage Normal (show e)@@ -270,7 +272,7 @@ treeStoreSetValue treeStore path var{varType = typ})) printVariable :: VarDescription -> TreePath -> TreeStore VarDescription -> IDEAction-printVariable varDescr path treeStore = do+printVariable varDescr path treeStore = packageTry_ $ tryDebug_ $ do debugCommand' (":print " ++ (varName varDescr)) (\to -> liftIO $ postGUIAsync (do case parse valueParser "" (selectString to) of Left e -> sysMessage Normal (show e)
src/IDE/Pane/Workspace.hs view
@@ -38,7 +38,6 @@ scrolledView :: ScrolledWindow , treeViewC :: TreeView , workspaceStore :: ListStore (Bool,IDEPackage)-, wsEntry :: Entry , topBox :: VBox } deriving Typeable @@ -111,12 +110,9 @@ sw <- scrolledWindowNew Nothing Nothing containerAdd sw treeView scrolledWindowSetPolicy sw PolicyAutomatic PolicyAutomatic- entry <- entryNew- set entry [ entryEditable := False ] box <- vBoxNew False 2- boxPackStart box entry PackNatural 0 boxPackEnd box sw PackGrow 0- let workspacePane = IDEWorkspace sw treeView listStore entry box+ let workspacePane = IDEWorkspace sw treeView listStore box widgetShowAll box cid1 <- treeView `afterFocusIn` (\_ -> do reflectIDE (makeActive workspacePane) ideR ; return True)@@ -154,15 +150,15 @@ sel <- getSelectionTree (treeViewC workspacePane) (workspaceStore workspacePane) case sel of- Just (_,ideP) -> reflectIDE (workspaceActivatePackage ideP) ideR+ Just (_,ideP) -> reflectIDE (workspaceTry_ $ workspaceActivatePackage ideP) ideR otherwise -> return ()- item2 `onActivateLeaf` reflectIDE workspaceAddPackage ideR+ item2 `onActivateLeaf` reflectIDE (workspaceTry_ $ workspaceAddPackage) ideR item3 `onActivateLeaf` do sel <- getSelectionTree (treeViewC workspacePane) (workspaceStore workspacePane) case sel of- Just (_,ideP) -> reflectIDE (workspaceRemovePackage ideP) ideR+ Just (_,ideP) -> reflectIDE (workspaceTry_ $ workspaceRemovePackage ideP) ideR otherwise -> return () menuShellAppend theMenu item1 menuShellAppend theMenu item2@@ -174,7 +170,7 @@ then do sel <- getSelectionTree (treeViewC workspacePane) (workspaceStore workspacePane) case sel of- Just (_,ideP) -> reflectIDE (workspaceActivatePackage ideP) ideR+ Just (_,ideP) -> reflectIDE (workspaceTry_ $ workspaceActivatePackage ideP) ideR >> return True otherwise -> return False else return False@@ -191,18 +187,16 @@ Nothing -> return () Just (p :: IDEWorkspace) -> do liftIO $ listStoreClear (workspaceStore p)- liftIO $ entrySetText (wsEntry p) "" when showPane $ displayPane p False Just ws -> do- when updateFileCache $ modifyIDE_ (\ide -> ide{bufferProjCache = Map.empty,- workspace = Just ws{wsReverseDeps = calculateReverseDependencies ws}})+ when updateFileCache $ modifyIDE_ (\ide -> ide{bufferProjCache = Map.empty}) mbMod <- getPane case mbMod of Nothing -> return () Just (p :: IDEWorkspace) -> do- liftIO $ entrySetText (wsEntry p) (wsName ws) liftIO $ listStoreClear (workspaceStore p)- let objs = map (\ ideP -> (Just ideP == wsActivePack ws, ideP)) (wsPackages ws)+ let objs = map (\ ideP -> (Just (ipdCabalFile ideP) == wsActivePackFile ws, ideP))+ (wsPackages ws) let sorted = sortBy (\ (_,f) (_,s) -> compare (ipdPackageId f) (ipdPackageId s)) objs liftIO $ mapM_ (listStoreAppend (workspaceStore p)) sorted when showPane $ displayPane p False
src/IDE/PaneGroups.hs view
@@ -46,6 +46,7 @@ import IDE.Pane.Breakpoints (IDEBreakpoints(..)) import IDE.Pane.Variables (IDEVariables(..)) import IDE.Pane.Trace (IDETrace(..))+import IDE.Pane.Workspace (IDEWorkspace(..)) showBrowser :: IDEAction showBrowser = do@@ -55,23 +56,31 @@ case ret of (Just rpp, True) -> do viewSplit' rpp Horizontal- let lowerP = rpp ++ [SplitP BottomP]- let upperP = rpp ++ [SplitP TopP]+ viewSplit' (rpp ++ [SplitP BottomP]) Horizontal+ let lowerP = rpp ++ [SplitP BottomP, SplitP BottomP]+ let upperP = rpp ++ [SplitP BottomP, SplitP TopP]+ let topP = rpp ++ [SplitP TopP] lower <- getNotebook lowerP upper <- getNotebook upperP+ top <- getNotebook topP liftIO $ do- notebookSetTabPos lower PosTop+ notebookSetTabPos lower PosBottom notebookSetTabPos upper PosTop+ notebookSetTabPos top PosTop notebookSetShowTabs upper False notebookSetShowTabs lower False+ notebookSetShowTabs top False getOrBuildPane (Left upperP) :: IDEM (Maybe IDEModules) getOrBuildPane (Left lowerP) :: IDEM (Maybe IDEInfo)+ getOrBuildPane (Left topP) :: IDEM (Maybe IDEWorkspace) return () (Just rpp, False) -> do- let lowerP = getBestPanePath (rpp ++ [SplitP BottomP]) layout'- let upperP = getBestPanePath (rpp ++ [SplitP TopP]) layout'+ let lowerP = getBestPanePath (rpp ++ [SplitP BottomP, SplitP BottomP]) layout'+ let upperP = getBestPanePath (rpp ++ [SplitP BottomP, SplitP TopP]) layout'+ let topP = getBestPanePath (rpp ++ [SplitP TopP]) layout' getOrBuildPane (Left upperP) :: IDEM (Maybe IDEModules) getOrBuildPane (Left lowerP) :: IDEM (Maybe IDEInfo)+ getOrBuildPane (Left topP) :: IDEM (Maybe IDEWorkspace) return () _ -> return ()
src/IDE/Session.hs view
@@ -43,7 +43,6 @@ import IDE.Pane.Modules import IDE.Pane.SourceBuffer import IDE.Pane.Info-import IDE.Pane.References import IDE.Pane.Log import IDE.Pane.Preferences import IDE.Pane.PackageFlags@@ -59,6 +58,7 @@ import Control.Exception (SomeException(..)) import IDE.Pane.Workspace (WorkspaceState(..)) import IDE.Workspaces (workspaceOpenThis)+import IDE.Completion (setCompletionSize) -- ---------------------------------------------------------------------@@ -75,7 +75,6 @@ | LogSt LogState | InfoSt InfoState | ModulesSt ModulesState- | ReferencesSt ReferencesState | PrefsSt PrefsState | FlagsSt FlagsState | SearchSt SearchState@@ -92,7 +91,6 @@ 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)@@ -109,7 +107,6 @@ recover pp (LogSt p) = recoverState pp p >> return () recover pp (InfoSt p) = recoverState pp p >> return () recover pp (ModulesSt p) = recoverState pp p >> return ()-recover pp (ReferencesSt p) = recoverState pp p >> return () recover pp (PrefsSt p) = recoverState pp p >> return () recover pp (FlagsSt p) = recoverState pp p >> return () recover pp (SearchSt p) = recoverState pp p >> return ()@@ -142,6 +139,7 @@ , layoutS :: PaneLayout , population :: [(Maybe PaneState,PanePath)] , windowSize :: (Int,Int)+ , completionSize :: (Int,Int) , workspacePath :: Maybe FilePath , activePaneN :: Maybe String , toolbarVisibleS :: Bool@@ -156,6 +154,7 @@ , layoutS = TerminalP Map.empty (Just TopP) (-1) Nothing Nothing , population = [] , windowSize = (1024,768)+ , completionSize = (750,400) , workspacePath = Nothing , activePaneN = Nothing , toolbarVisibleS = True@@ -206,6 +205,12 @@ windowSize (\(c,d) a -> a{windowSize = (c,d)}) , mkFieldS+ (paraName <<<- ParaName "Completion size" $ emptyParams)+ (PP.text . show)+ (pairParser intParser)+ completionSize+ (\(c,d) a -> a{completionSize = (c,d)})+ , mkFieldS (paraName <<<- ParaName "Workspace" $ emptyParams) (PP.text . show) readParser@@ -273,6 +278,7 @@ layout <- mkLayout population <- getPopulation size <- liftIO $ windowGetSize wdw+ (completionSize,_) <- readIDE completion mbWs <- readIDE workspace activePane' <- getActivePane let activeP = case activePane' of@@ -290,6 +296,7 @@ , layoutS = layout , population = population , windowSize = size+ , completionSize = completionSize , workspacePath = case mbWs of Nothing -> Nothing Just ws -> Just (wsFile ws)@@ -467,6 +474,7 @@ if (fst . findbarState) sessionSt then showFindbar else hideFindbar+ setCompletionSize (completionSize sessionSt) modifyIDE_ (\ide -> ide{recentFiles = recentOpenedFiles sessionSt, recentWorkspaces = recentOpenedWorksp sessionSt}) return (toolbarVisibleS sessionSt, (fst . findbarState) sessionSt))
src/IDE/SourceCandy.hs view
@@ -29,7 +29,7 @@ import Prelude hiding(getChar, getLine) import Data.Char(chr)-import Data.List(isSuffixOf)+import Data.List (elemIndices, isInfixOf, isSuffixOf) import Text.ParserCombinators.Parsec import qualified Text.ParserCombinators.Parsec.Token as P import Text.ParserCombinators.Parsec.Language(emptyDef)@@ -37,6 +37,7 @@ import IDE.Core.State import IDE.TextEditor+import Control.Monad (unless) --------------------------------------------------------------------------------- -- * Implementation@@ -44,22 +45,25 @@ notBeforeId = Set.fromList $['a'..'z'] ++ ['A'..'Z'] ++ ['_'] notAfterId = Set.fromList $['a'..'z'] ++ ['A'..'Z'] ++ ['0'..'9'] ++ ['_'] notBeforeOp = Set.fromList $['!','#','$','%','&','*','+','.','/','<','=','>','?','@','\\',- '^','|','-','~','\'','"','\n']+ '^','|','-','~','\'','"'] notAfterOp = notBeforeOp keystrokeCandy :: CandyTable -> Maybe Char -> EditorBuffer -> IDEM () keystrokeCandy (CT(transformTable,_)) mbc ebuf = do cursorMark <- getInsertMark ebuf endIter <- getIterAtMark ebuf cursorMark+ lineNr <- getLine endIter+ columnNr <- getLineOffset endIter offset <- getOffset endIter- let sliceStart = if offset < 8 then 0 else offset - 8- startIter <- getIterAtOffset ebuf sliceStart+ startIter <- backwardToLineStartC endIter slice <- getSlice ebuf startIter endIter True mbc2 <- case mbc of Just c -> return (Just c) Nothing -> do getChar endIter- replace mbc2 cursorMark slice offset transformTable+ block <- isInCommentOrString lineNr columnNr slice+ unless block $+ replace mbc2 cursorMark slice offset transformTable where replace :: Maybe Char -> EditorMark -> String -> Int -> [(Bool,String,String)] -> IDEM () replace mbAfterChar cursorMark match offset list = replace' list@@ -106,37 +110,43 @@ Nothing -> return () Just (st,end) -> do stOff <- getOffset st- beforeOk <-- if stOff == 0- then return True- else do- iter <- getIterAtOffset buf (stOff - 1)- mbChar <- getChar iter- case mbChar of- Nothing -> return True- Just char -> return (not $if isOp- then Set.member char notBeforeOp- else Set.member char notBeforeId)- if beforeOk- then do- afterOk <- do- endOff <- getOffset end- iter <- getIterAtOffset buf endOff- mbChar <- getChar iter- case mbChar of- Nothing -> return True- Just char -> return (not $if isOp- then Set.member char notAfterOp- else Set.member char notAfterId)- if afterOk- then do- delete buf st end- insert buf st to- return ()+ lineNr <- getLine end+ columnNr <- getLineOffset end+ startIter <- backwardToLineStartC end+ slice <- getSlice buf startIter end True+ block <- isInCommentOrString lineNr columnNr slice+ unless block $ do+ beforeOk <-+ if stOff == 0+ then return True else do- return ()- else do- return ()+ iter <- getIterAtOffset buf (stOff - 1)+ mbChar <- getChar iter+ case mbChar of+ Nothing -> return True+ Just char -> return (not $if isOp+ then Set.member char notBeforeOp+ else Set.member char notBeforeId)+ if beforeOk+ then do+ afterOk <- do+ endOff <- getOffset end+ iter <- getIterAtOffset buf endOff+ mbChar <- getChar iter+ case mbChar of+ Nothing -> return True+ Just char -> return (not $if isOp+ then Set.member char notAfterOp+ else Set.member char notAfterId)+ if afterOk+ then do+ delete buf st end+ insert buf st to+ return ()+ else do+ return ()+ else do+ return () replaceTo' (stOff + 1) transformFromCandy :: CandyTable -> EditorBuffer -> IDEM ()@@ -302,3 +312,16 @@ char '0' hd <- lexeme hexadecimal return (chr (fromIntegral hd))++-- TODO Literal Haskell+isInCommentOrString :: Int -> Int -> String -> IDEM Bool+isInCommentOrString line column preLine =+ if isInfixOf "--" preLine+ then return True+ else let indices = elemIndices '"' preLine+ in if length indices == 0+ then return False+ else if even (length indices) -- TODO Handle \"+ then return False+ else return True+
src/IDE/TextEditor.hs view
@@ -77,6 +77,7 @@ , scrollToIter , setFont , setIndentWidth+, setWrapMode , setRightMargin , setShowLineNumbers , setTabWidth@@ -85,6 +86,7 @@ , backwardCharC , backwardFindCharC , backwardWordStartC+, backwardToLineStartC , endsWord , forwardCharC , forwardCharsC@@ -130,7 +132,7 @@ ) where import Prelude hiding(getChar, getLine)-import Data.Char (isAlphaNum)+import Data.Char (isAlphaNum, isSymbol) import Data.Maybe (fromJust) import Control.Monad (when) import Control.Monad.Reader (liftIO, ask)@@ -138,12 +140,10 @@ import qualified Graphics.UI.Gtk as Gtk hiding(afterToggleOverwrite) import qualified Graphics.UI.Gtk.SourceView as Gtk-import qualified Graphics.UI.Gtk.Multiline.TextView as Gtk import qualified Graphics.UI.Gtk.Gdk.Events as GtkOld-import qualified Graphics.UI.Gtk.Gdk.EventM as Gtk import System.Glib.Attributes (AttrOp(..)) -#ifdef YI+#ifdef LEKSAH_WITH_YI import qualified Yi as Yi hiding(withBuffer) import qualified Yi.UI.Pango.Control as Yi import qualified Yi.Keymap.Cua as Yi@@ -158,36 +158,36 @@ -- Data types data EditorBuffer = GtkEditorBuffer Gtk.SourceBuffer-#ifdef YI+#ifdef LEKSAH_WITH_YI | YiEditorBuffer Yi.Buffer #endif data EditorView = GtkEditorView Gtk.SourceView-#ifdef YI+#ifdef LEKSAH_WITH_YI | YiEditorView Yi.View #endif data EditorMark = GtkEditorMark Gtk.TextMark-#ifdef YI+#ifdef LEKSAH_WITH_YI | YiEditorMark Yi.Mark #endif data EditorIter = GtkEditorIter Gtk.TextIter-#ifdef YI+#ifdef LEKSAH_WITH_YI | YiEditorIter Yi.Iter #endif data EditorTagTable = GtkEditorTagTable Gtk.TextTagTable-#ifdef YI+#ifdef LEKSAH_WITH_YI | YiEditorTagTable #endif data EditorTag = GtkEditorTag Gtk.TextTag-#ifdef YI+#ifdef LEKSAH_WITH_YI | YiEditorTag #endif -#ifdef YI+#ifdef LEKSAH_WITH_YI withYiBuffer' :: Yi.BufferRef -> Yi.BufferM a -> IDEM a withYiBuffer' b f = liftYi $ Yi.liftEditor $ Yi.withGivenBuffer0 b f @@ -232,7 +232,7 @@ newYiBuffer :: Maybe FilePath -> String -> IDEM EditorBuffer-#ifdef YI+#ifdef LEKSAH_WITH_YI newYiBuffer mbFilename contents = liftYiControl $ do let (filename, id) = case mbFilename of Just fn -> (fn, Right fn)@@ -251,38 +251,38 @@ -> IDEM () applyTagByName (GtkEditorBuffer sb) name (GtkEditorIter first) (GtkEditorIter last) = liftIO $ Gtk.textBufferApplyTagByName sb name first last-#ifdef YI+#ifdef LEKSAH_WITH_YI applyTagByName (YiEditorBuffer fb) name (YiEditorIter first) (YiEditorIter last) = return () -- TODO applyTagByName _ _ _ _ = liftIO $ fail "Mismatching TextEditor types in createMark" #endif beginNotUndoableAction :: EditorBuffer -> IDEM () beginNotUndoableAction (GtkEditorBuffer sb) = liftIO $ Gtk.sourceBufferBeginNotUndoableAction sb-#ifdef YI+#ifdef LEKSAH_WITH_YI beginNotUndoableAction (YiEditorBuffer fb) = return () -- TODO #endif beginUserAction :: EditorBuffer -> IDEM () beginUserAction (GtkEditorBuffer sb) = liftIO $ Gtk.textBufferBeginUserAction sb-#ifdef YI+#ifdef LEKSAH_WITH_YI beginUserAction (YiEditorBuffer fb) = return () -- TODO #endif canRedo :: EditorBuffer -> IDEM Bool canRedo (GtkEditorBuffer sb) = liftIO $ Gtk.sourceBufferGetCanRedo sb-#ifdef YI+#ifdef LEKSAH_WITH_YI canRedo (YiEditorBuffer fb) = return True -- TODO #endif canUndo :: EditorBuffer -> IDEM Bool canUndo (GtkEditorBuffer sb) = liftIO $ Gtk.sourceBufferGetCanUndo sb-#ifdef YI+#ifdef LEKSAH_WITH_YI canUndo (YiEditorBuffer fb) = return True -- TODO #endif copyClipboard :: EditorBuffer -> Gtk.Clipboard -> IDEM () copyClipboard (GtkEditorBuffer sb) clipboard = liftIO $ Gtk.textBufferCopyClipboard sb clipboard-#ifdef YI+#ifdef LEKSAH_WITH_YI copyClipboard (YiEditorBuffer fb) _ = liftYi $ Yi.liftEditor $ Yi.copy #endif @@ -292,7 +292,7 @@ -> IDEM EditorMark createMark (GtkEditorBuffer sb) (GtkEditorIter i) leftGravity = liftIO $ GtkEditorMark <$> Gtk.textBufferCreateMark sb Nothing i leftGravity-#ifdef YI+#ifdef LEKSAH_WITH_YI createMark (YiEditorBuffer b) (YiEditorIter (Yi.Iter _ p)) leftGravity = withYiBuffer b $ YiEditorMark <$> Yi.newMarkB (Yi.MarkValue p (if leftGravity then Yi.Backward else Yi.Forward)) createMark _ _ _ = liftIO $ fail "Mismatching TextEditor types in createMark"@@ -300,14 +300,14 @@ cutClipboard :: EditorBuffer -> Gtk.Clipboard -> Bool -> IDEM () cutClipboard (GtkEditorBuffer sb) clipboard defaultEditable = liftIO $ Gtk.textBufferCutClipboard sb clipboard defaultEditable-#ifdef YI+#ifdef LEKSAH_WITH_YI cutClipboard (YiEditorBuffer fb) clipboard defaultEditable = liftYi $ Yi.liftEditor $ Yi.cut #endif delete :: EditorBuffer -> EditorIter -> EditorIter -> IDEM () delete (GtkEditorBuffer sb) (GtkEditorIter first) (GtkEditorIter last) = liftIO $ Gtk.textBufferDelete sb first last-#ifdef YI+#ifdef LEKSAH_WITH_YI delete (YiEditorBuffer b) (YiEditorIter (Yi.Iter _ first)) (YiEditorIter (Yi.Iter _ last)) = withYiBuffer b $ Yi.deleteRegionB $ Yi.mkRegion first last delete _ _ _ = liftIO $ fail "Mismatching TextEditor types in delete"@@ -316,7 +316,7 @@ deleteSelection :: EditorBuffer -> Bool -> Bool -> IDEM () deleteSelection (GtkEditorBuffer sb) interactive defaultEditable = liftIO $ Gtk.textBufferDeleteSelection sb interactive defaultEditable >> return ()-#ifdef YI+#ifdef LEKSAH_WITH_YI deleteSelection (YiEditorBuffer b) interactive defaultEditable = withYiBuffer b $ do region <- Yi.getRawestSelectRegionB Yi.deleteRegionB region -- TODO support flags@@ -324,62 +324,62 @@ endNotUndoableAction :: EditorBuffer -> IDEM () endNotUndoableAction (GtkEditorBuffer sb) = liftIO $ Gtk.sourceBufferEndNotUndoableAction sb-#ifdef YI+#ifdef LEKSAH_WITH_YI endNotUndoableAction (YiEditorBuffer fb) = return () -- TODO #endif endUserAction :: EditorBuffer -> IDEM () endUserAction (GtkEditorBuffer sb) = liftIO $ Gtk.textBufferEndUserAction sb-#ifdef YI+#ifdef LEKSAH_WITH_YI endUserAction (YiEditorBuffer fb) = return () -- TODO #endif getEndIter :: EditorBuffer -> IDEM EditorIter getEndIter (GtkEditorBuffer sb) = liftIO $ GtkEditorIter <$> Gtk.textBufferGetEndIter sb-#ifdef YI+#ifdef LEKSAH_WITH_YI getEndIter (YiEditorBuffer b) = iterFromYiBuffer b Yi.sizeB #endif getInsertMark :: EditorBuffer -> IDEM EditorMark getInsertMark (GtkEditorBuffer sb) = liftIO $ fmap GtkEditorMark $ Gtk.textBufferGetInsert sb-#ifdef YI+#ifdef LEKSAH_WITH_YI getInsertMark (YiEditorBuffer b) = YiEditorMark <$> (withYiBuffer b $ Yi.insMark <$> Yi.askMarks) #endif getIterAtLine :: EditorBuffer -> Int -> IDEM EditorIter getIterAtLine (GtkEditorBuffer sb) line = liftIO $ GtkEditorIter <$> Gtk.textBufferGetIterAtLine sb line-#ifdef YI+#ifdef LEKSAH_WITH_YI getIterAtLine (YiEditorBuffer b) line = iterFromYiBuffer b $ Yi.pointOfLineColB line 1 #endif getIterAtMark :: EditorBuffer -> EditorMark -> IDEM EditorIter getIterAtMark (GtkEditorBuffer sb) (GtkEditorMark m) = liftIO $ GtkEditorIter <$> Gtk.textBufferGetIterAtMark sb m-#ifdef YI+#ifdef LEKSAH_WITH_YI getIterAtMark (YiEditorBuffer b) (YiEditorMark m) = iterFromYiBuffer b $ Yi.getMarkPointB m getIterAtMark _ _ = liftIO $ fail "Mismatching TextEditor types in getIterAtMark" #endif getIterAtOffset :: EditorBuffer -> Int -> IDEM EditorIter getIterAtOffset (GtkEditorBuffer sb) offset = liftIO $ GtkEditorIter <$> Gtk.textBufferGetIterAtOffset sb offset-#ifdef YI+#ifdef LEKSAH_WITH_YI getIterAtOffset (YiEditorBuffer b) offset = return $ mkYiIter b $ Yi.Point offset #endif getLineCount :: EditorBuffer -> IDEM Int getLineCount (GtkEditorBuffer sb) = liftIO $ Gtk.textBufferGetLineCount sb-#ifdef YI+#ifdef LEKSAH_WITH_YI getLineCount (YiEditorBuffer b) = withYiBuffer b $ Yi.sizeB >>= Yi.lineOf #endif getModified :: EditorBuffer -> IDEM Bool getModified (GtkEditorBuffer sb) = liftIO $ Gtk.textBufferGetModified sb-#ifdef YI+#ifdef LEKSAH_WITH_YI getModified (YiEditorBuffer b) = not <$> (withYiBuffer b $ Yi.gets Yi.isUnchangedBuffer) #endif getSelectionBoundMark :: EditorBuffer -> IDEM EditorMark getSelectionBoundMark (GtkEditorBuffer sb) = liftIO $ fmap GtkEditorMark $ Gtk.textBufferGetSelectionBound sb-#ifdef YI+#ifdef LEKSAH_WITH_YI getSelectionBoundMark (YiEditorBuffer b) = YiEditorMark . Yi.selMark <$> (withYiBuffer b $ Yi.askMarks) #endif @@ -387,7 +387,7 @@ getSelectionBounds (GtkEditorBuffer sb) = liftIO $ do (first, last) <- Gtk.textBufferGetSelectionBounds sb return (GtkEditorIter first, GtkEditorIter last)-#ifdef YI+#ifdef LEKSAH_WITH_YI getSelectionBounds (YiEditorBuffer b) = withYiBuffer b $ do region <- Yi.getRawestSelectRegionB return (mkYiIter b (Yi.regionStart region),@@ -401,7 +401,7 @@ -> IDEM String getSlice (GtkEditorBuffer sb) (GtkEditorIter first) (GtkEditorIter last) includeHidenChars = liftIO $ Gtk.textBufferGetSlice sb first last includeHidenChars-#ifdef YI+#ifdef LEKSAH_WITH_YI getSlice (YiEditorBuffer b) (YiEditorIter first) (YiEditorIter last) includeHidenChars = liftYiControl $ Yi.getText b first last getSlice _ _ _ _ = liftIO $ fail "Mismatching TextEditor types in getSlice"@@ -409,13 +409,13 @@ getStartIter :: EditorBuffer -> IDEM EditorIter getStartIter (GtkEditorBuffer sb) = liftIO $ GtkEditorIter <$> Gtk.textBufferGetStartIter sb-#ifdef YI+#ifdef LEKSAH_WITH_YI getStartIter (YiEditorBuffer b) = return $ mkYiIter b $ Yi.Point 0 #endif getTagTable :: EditorBuffer -> IDEM EditorTagTable getTagTable (GtkEditorBuffer sb) = liftIO $ fmap GtkEditorTagTable $ Gtk.textBufferGetTagTable sb-#ifdef YI+#ifdef LEKSAH_WITH_YI getTagTable (YiEditorBuffer b) = return YiEditorTagTable -- TODO #endif @@ -426,7 +426,7 @@ -> IDEM String getText (GtkEditorBuffer sb) (GtkEditorIter first) (GtkEditorIter last) includeHidenChars = liftIO $ Gtk.textBufferGetText sb first last includeHidenChars-#ifdef YI+#ifdef LEKSAH_WITH_YI getText (YiEditorBuffer b) (YiEditorIter first) (YiEditorIter last) includeHidenChars = liftYiControl $ Yi.getText b first last getText _ _ _ _ = liftIO $ fail "Mismatching TextEditor types in getText"@@ -434,7 +434,7 @@ hasSelection :: EditorBuffer -> IDEM Bool hasSelection (GtkEditorBuffer sb) = liftIO $ Gtk.textBufferHasSelection sb-#ifdef YI+#ifdef LEKSAH_WITH_YI hasSelection (YiEditorBuffer b) = withYiBuffer b $ do region <- Yi.getRawestSelectRegionB return $ not $ Yi.regionIsEmpty region@@ -442,20 +442,21 @@ insert :: EditorBuffer -> EditorIter -> String -> IDEM () insert (GtkEditorBuffer sb) (GtkEditorIter i) text = liftIO $ Gtk.textBufferInsert sb i text-#ifdef YI+#ifdef LEKSAH_WITH_YI insert (YiEditorBuffer b) (YiEditorIter (Yi.Iter _ p)) text = withYiBuffer b $ Yi.insertNAt text p insert _ _ _ = liftIO $ fail "Mismatching TextEditor types in insert" #endif moveMark :: EditorBuffer -> EditorMark -> EditorIter -> IDEM () moveMark (GtkEditorBuffer sb) (GtkEditorMark m) (GtkEditorIter i) = liftIO $ Gtk.textBufferMoveMark sb m i-#ifdef YI+#ifdef LEKSAH_WITH_YI moveMark (YiEditorBuffer b) (YiEditorMark m) (YiEditorIter (Yi.Iter _ p)) = withYiBuffer b $ Yi.setMarkPointB m p moveMark _ _ _ = liftIO $ fail "Mismatching TextEditor types in moveMark" #endif newView :: EditorBuffer -> Maybe String -> IDEM EditorView newView (GtkEditorBuffer sb) mbFontString = do+ prefs <- readIDE prefs fd <- fontDescription mbFontString liftIO $ do sv <- Gtk.sourceViewNewWithBuffer sb@@ -464,11 +465,14 @@ Gtk.sourceViewSetIndentOnTab sv True Gtk.sourceViewSetAutoIndent sv True Gtk.sourceViewSetSmartHomeEnd sv Gtk.SourceSmartHomeEndBefore+ if wrapLines prefs+ then Gtk.textViewSetWrapMode sv Gtk.WrapWord+ else Gtk.textViewSetWrapMode sv Gtk.WrapNone sw <- Gtk.scrolledWindowNew Nothing Nothing Gtk.containerAdd sw sv Gtk.widgetModifyFont sv (Just fd) return (GtkEditorView sv)-#ifdef YI+#ifdef LEKSAH_WITH_YI newView (YiEditorBuffer b) mbFontString = do fd <- fontDescription mbFontString liftYiControl $ fmap YiEditorView $ Yi.newView b fd@@ -481,21 +485,21 @@ -> IDEM () pasteClipboard (GtkEditorBuffer sb) clipboard (GtkEditorIter i) defaultEditable = liftIO $ Gtk.textBufferPasteClipboard sb clipboard i defaultEditable-#ifdef YI+#ifdef LEKSAH_WITH_YI pasteClipboard (YiEditorBuffer b) clipboard (YiEditorIter (Yi.Iter _ p)) defaultEditable = liftYi $ Yi.liftEditor $ Yi.paste pasteClipboard _ _ _ _ = liftIO $ fail "Mismatching TextEditor types in pasteClipboard" #endif placeCursor :: EditorBuffer -> EditorIter -> IDEM () placeCursor (GtkEditorBuffer sb) (GtkEditorIter i) = liftIO $ Gtk.textBufferPlaceCursor sb i-#ifdef YI+#ifdef LEKSAH_WITH_YI placeCursor (YiEditorBuffer b) (YiEditorIter (Yi.Iter _ p)) = withYiBuffer b $ Yi.moveTo p placeCursor _ _ = liftIO $ fail "Mismatching TextEditor types in placeCursor" #endif redo :: EditorBuffer -> IDEM () redo (GtkEditorBuffer sb) = liftIO $ Gtk.sourceBufferRedo sb-#ifdef YI+#ifdef LEKSAH_WITH_YI redo (YiEditorBuffer b) = withYiBuffer b Yi.redoB #endif @@ -506,7 +510,7 @@ -> IDEM () removeTagByName (GtkEditorBuffer sb) name (GtkEditorIter first) (GtkEditorIter last) = liftIO $ Gtk.textBufferRemoveTagByName sb name first last-#ifdef YI+#ifdef LEKSAH_WITH_YI removeTagByName (YiEditorBuffer b) name (YiEditorIter (Yi.Iter _ first)) (YiEditorIter (Yi.Iter _ last)) = return () -- TODO removeTagByName _ _ _ _ = liftIO $ fail "Mismatching TextEditor types in removeTagByName" #endif@@ -514,7 +518,7 @@ selectRange :: EditorBuffer -> EditorIter -> EditorIter -> IDEM () selectRange (GtkEditorBuffer sb) (GtkEditorIter first) (GtkEditorIter last) = liftIO $ Gtk.textBufferSelectRange sb first last-#ifdef YI+#ifdef LEKSAH_WITH_YI selectRange (YiEditorBuffer b) (YiEditorIter (Yi.Iter _ first)) (YiEditorIter (Yi.Iter _ last)) = withYiBuffer b $ Yi.setSelectRegionB $ Yi.mkRegion first last selectRange _ _ _ = liftIO $ fail "Mismatching TextEditor types in selectRange"@@ -522,7 +526,7 @@ setModified :: EditorBuffer -> Bool -> IDEM () setModified (GtkEditorBuffer sb) modified = liftIO $ Gtk.textBufferSetModified sb modified >> return ()-#ifdef YI+#ifdef LEKSAH_WITH_YI setModified (YiEditorBuffer b) modified = unless modified $ do now <- liftIO $ getCurrentTime withYiBuffer b $ Yi.markSavedB now@@ -537,64 +541,69 @@ ids <- Gtk.sourceStyleSchemeManagerGetSchemeIds styleManager when (elem str ids) $ do scheme <- Gtk.sourceStyleSchemeManagerGetScheme styleManager str+#if MIN_VERSION_gtksourceview2(0,12,0)+ Gtk.sourceBufferSetStyleScheme sb (Just scheme)+#else Gtk.sourceBufferSetStyleScheme sb scheme-#ifdef YI+#endif++#ifdef LEKSAH_WITH_YI setStyle (YiEditorBuffer b) mbStyle = return () -- TODO #endif setText :: EditorBuffer -> String -> IDEM () setText (GtkEditorBuffer sb) text = liftIO $ Gtk.textBufferSetText sb text-#ifdef YI+#ifdef LEKSAH_WITH_YI setText (YiEditorBuffer b) text = liftYiControl $ Yi.setText b text #endif undo :: EditorBuffer -> IDEM () undo (GtkEditorBuffer sb) = liftIO $ Gtk.sourceBufferUndo sb-#ifdef YI+#ifdef LEKSAH_WITH_YI undo (YiEditorBuffer b) = withYiBuffer b Yi.undoB #endif -- View bufferToWindowCoords :: EditorView -> (Int, Int) -> IDEM (Int, Int) bufferToWindowCoords (GtkEditorView sv) point = liftIO $ Gtk.textViewBufferToWindowCoords sv Gtk.TextWindowWidget point-#ifdef YI+#ifdef LEKSAH_WITH_YI bufferToWindowCoords (YiEditorView v) point = return point -- TODO #endif getBuffer :: EditorView -> IDEM EditorBuffer getBuffer (GtkEditorView sv) = liftIO $ fmap (GtkEditorBuffer . Gtk.castToSourceBuffer) $ sv `Gtk.get` Gtk.textViewBuffer-#ifdef YI+#ifdef LEKSAH_WITH_YI getBuffer (YiEditorView v) = return $ YiEditorBuffer $ Yi.getBuffer v #endif getDrawWindow :: EditorView -> IDEM Gtk.DrawWindow getDrawWindow (GtkEditorView sv) = liftIO $ Gtk.widgetGetDrawWindow sv-#ifdef YI+#ifdef LEKSAH_WITH_YI getDrawWindow (YiEditorView v) = liftIO $ Gtk.widgetGetDrawWindow (Yi.drawArea v) #endif getIterLocation :: EditorView -> EditorIter -> IDEM Gtk.Rectangle getIterLocation (GtkEditorView sv) (GtkEditorIter i) = liftIO $ Gtk.textViewGetIterLocation sv i-#ifdef YI+#ifdef LEKSAH_WITH_YI getIterLocation (YiEditorView v) (YiEditorIter i) = return $ Gtk.Rectangle 0 0 0 0 -- TODO getIterLocation _ _ = liftIO $ fail "Mismatching TextEditor types in getIterLocation" #endif getOverwrite :: EditorView -> IDEM Bool getOverwrite (GtkEditorView sv) = liftIO $ Gtk.textViewGetOverwrite sv-#ifdef YI+#ifdef LEKSAH_WITH_YI getOverwrite (YiEditorView Yi.View{Yi.viewFBufRef = b}) = withYiBuffer' b $ not <$> Yi.getA Yi.insertingA #endif getScrolledWindow :: EditorView -> IDEM Gtk.ScrolledWindow getScrolledWindow (GtkEditorView sv) = liftIO $ fmap (Gtk.castToScrolledWindow . fromJust) $ Gtk.widgetGetParent sv-#ifdef YI+#ifdef LEKSAH_WITH_YI getScrolledWindow (YiEditorView v) = return $ Yi.scrollWin v #endif grabFocus :: EditorView -> IDEM () grabFocus (GtkEditorView sv) = liftIO $ Gtk.widgetGrabFocus sv-#ifdef YI+#ifdef LEKSAH_WITH_YI grabFocus (YiEditorView Yi.View{Yi.drawArea = da}) = liftIO $ Gtk.widgetGrabFocus da #endif @@ -604,7 +613,7 @@ -> Maybe (Double, Double) -> IDEM () scrollToMark (GtkEditorView sv) (GtkEditorMark m) withMargin mbAlign = liftIO $ Gtk.textViewScrollToMark sv m withMargin mbAlign-#ifdef YI+#ifdef LEKSAH_WITH_YI scrollToMark (YiEditorView v) (YiEditorMark m) withMargin mbAlign = return () -- TODO scrollToMark _ _ _ _ = liftIO $ fail "Mismatching TextEditor types in scrollToMark" #endif@@ -615,7 +624,7 @@ -> Maybe (Double, Double) -> IDEM () scrollToIter (GtkEditorView sv) (GtkEditorIter i) withMargin mbAlign = liftIO $ Gtk.textViewScrollToIter sv i withMargin mbAlign >> return ()-#ifdef YI+#ifdef LEKSAH_WITH_YI scrollToIter (YiEditorView v) (YiEditorIter i) withMargin mbAlign = return () -- TODO scrollToIter _ _ _ _ = liftIO $ fail "Mismatching TextEditor types in scrollToIter" #endif@@ -634,7 +643,7 @@ setFont (GtkEditorView sv) mbFontString = do fd <- fontDescription mbFontString liftIO $ Gtk.widgetModifyFont sv (Just fd)-#ifdef YI+#ifdef LEKSAH_WITH_YI setFont (YiEditorView v) mbFontString = do fd <- fontDescription mbFontString liftIO $ Gtk.layoutSetFontDescription (Yi.layout v) (Just fd)@@ -642,10 +651,28 @@ setIndentWidth :: EditorView -> Int -> IDEM () setIndentWidth (GtkEditorView sv) width = liftIO $ Gtk.sourceViewSetIndentWidth sv width-#ifdef YI-setIndentWidth (YiEditorView v) width = return () -- TODO+#ifdef LEKSAH_WITH_YI+setIndentWidth (YiEditorView Yi.View{Yi.viewFBufRef = b}) width =+ withYiBuffer' b $ Yi.modifyMode $+ \ (mode@Yi.Mode{Yi.modeIndentSettings = mis}) ->+ mode{Yi.modeIndentSettings = mis{Yi.shiftWidth = width}} #endif +setWrapMode :: EditorView -> Bool-> IDEM ()+setWrapMode ev@(GtkEditorView sv) wrapLines = do+ sw <- getScrolledWindow ev+ if wrapLines+ then liftIO $ do+ Gtk.textViewSetWrapMode sv Gtk.WrapWord+ Gtk.scrolledWindowSetPolicy sw Gtk.PolicyNever Gtk.PolicyAutomatic+ else liftIO $ do+ Gtk.textViewSetWrapMode sv Gtk.WrapNone+ Gtk.scrolledWindowSetPolicy sw Gtk.PolicyAutomatic Gtk.PolicyAutomatic+#ifdef LEKSAH_WITH_YI+setWrapMode (YiEditorView Yi.View{Yi.viewFBufRef = b}) width = return ()+#endif++ setRightMargin :: EditorView -> Maybe Int -> IDEM () setRightMargin (GtkEditorView sv) mbRightMargin = liftIO $ do case mbRightMargin of@@ -653,20 +680,23 @@ Gtk.sourceViewSetShowRightMargin sv True Gtk.sourceViewSetRightMarginPosition sv (fromIntegral n) Nothing -> Gtk.sourceViewSetShowRightMargin sv False-#ifdef YI+#ifdef LEKSAH_WITH_YI setRightMargin (YiEditorView v) mbRightMargin = return () -- TODO #endif setShowLineNumbers :: EditorView -> Bool -> IDEM () setShowLineNumbers (GtkEditorView sv) show = liftIO $ Gtk.sourceViewSetShowLineNumbers sv show-#ifdef YI+#ifdef LEKSAH_WITH_YI setShowLineNumbers (YiEditorView v) show = return () -- TODO #endif setTabWidth :: EditorView -> Int -> IDEM () setTabWidth (GtkEditorView sv) width = liftIO $ Gtk.sourceViewSetTabWidth sv width-#ifdef YI-setTabWidth (YiEditorView v) width = return () -- TODO+#ifdef LEKSAH_WITH_YI+setTabWidth (YiEditorView Yi.View{Yi.viewFBufRef = b}) width =+ withYiBuffer' b $ Yi.modifyMode $+ \ (mode@Yi.Mode{Yi.modeIndentSettings = mis}) ->+ mode{Yi.modeIndentSettings = mis{Yi.tabSize = width}} #endif -- Iterator@@ -684,26 +714,33 @@ then Just $ GtkEditorIter new else Nothing -#ifdef YI+#ifdef LEKSAH_WITH_YI withYiIter :: Yi.Iter -> Yi.BufferM a -> IDEM a withYiIter (Yi.Iter b p) f = withYiBuffer' b $ do- oldPoint <- Yi.pointB- insertMark <- Yi.insMark <$> Yi.askMarks- Yi.setMarkPointB insertMark p -- Using this becauls moveTo forgets the prefered column- result <- f- Yi.setMarkPointB insertMark oldPoint- return result+ Yi.savingPointB $ do+ Yi.moveTo p+ f transformYiIter' :: Yi.Iter -> Yi.BufferM Yi.Point -> IDEM EditorIter transformYiIter' i f = mkYiIter' (Yi.iterFBufRef i) <$> withYiIter i f transformYiIter :: Yi.Iter -> Yi.BufferM a -> IDEM EditorIter transformYiIter i f = transformYiIter' i (f >> Yi.pointB)++tryTransformYiIter' :: Yi.Iter -> Yi.BufferM Yi.Point -> IDEM (Maybe EditorIter)+tryTransformYiIter' i@(Yi.Iter b p) f = withYiIter i $ do+ newPoint <- f+ if p == newPoint+ then return Nothing+ else return . Just $ mkYiIter' b newPoint++tryTransformYiIter :: Yi.Iter -> Yi.BufferM a -> IDEM (Maybe EditorIter)+tryTransformYiIter i f = tryTransformYiIter' i (f >> Yi.pointB) #endif backwardCharC :: EditorIter -> IDEM EditorIter backwardCharC (GtkEditorIter i) = transformGtkIter i Gtk.textIterBackwardChar-#ifdef YI+#ifdef LEKSAH_WITH_YI backwardCharC (YiEditorIter i) = transformYiIter' i Yi.prevPointB #endif @@ -716,35 +753,51 @@ case mbLimit of Just (GtkEditorIter limit) -> Just limit Nothing -> Nothing-#ifdef YI+#ifdef LEKSAH_WITH_YI _ -> fail "Mismatching TextEditor types in backwardFindChar" #endif -#ifdef YI-backwardFindCharC (YiEditorIter i) pred mbLimit = return Nothing -- TODO+#ifdef LEKSAH_WITH_YI+backwardFindCharC (YiEditorIter i) pred mbLimit = tryTransformYiIter i $+ Yi.doUntilB_ (pred <$> Yi.readB) Yi.leftB #endif backwardWordStartC :: EditorIter -> IDEM (Maybe EditorIter) backwardWordStartC (GtkEditorIter i) = transformGtkIterMaybe i Gtk.textIterBackwardWordStart-#ifdef YI-backwardWordStartC (YiEditorIter i) = return Nothing -- TODO+#ifdef LEKSAH_WITH_YI+backwardWordStartC (YiEditorIter i@(Yi.Iter b p)) = withYiIter i $ do+ Yi.prevWordB+ newPoint <- Yi.pointB+ if p == newPoint+ then return Nothing+ else return . Just $ mkYiIter' b newPoint #endif +backwardToLineStartC :: EditorIter -> IDEM EditorIter+backwardToLineStartC (GtkEditorIter i) = transformGtkIter i $ \new -> do+ n <- Gtk.textIterGetLineOffset new+ Gtk.textIterBackwardChars new n+ return ()+#ifdef LEKSAH_WITH_YI+backwardToLineStartC (YiEditorIter i) = transformYiIter i Yi.moveToSol+#endif+ endsWord :: EditorIter -> IDEM Bool endsWord (GtkEditorIter i) = liftIO $ Gtk.textIterEndsWord i-#ifdef YI-endsWord (YiEditorIter i) = return False -- TODO+#ifdef LEKSAH_WITH_YI+endsWord (YiEditorIter i) = withYiIter i $ do+ Yi.atBoundaryB Yi.unitWord Yi.Forward #endif forwardCharC :: EditorIter -> IDEM EditorIter forwardCharC (GtkEditorIter i) = transformGtkIter i Gtk.textIterForwardChar-#ifdef YI+#ifdef LEKSAH_WITH_YI forwardCharC (YiEditorIter i) = transformYiIter' i Yi.nextPointB #endif forwardCharsC :: EditorIter -> Int -> IDEM EditorIter forwardCharsC (GtkEditorIter i) n = transformGtkIter i $ flip Gtk.textIterForwardChars n-#ifdef YI+#ifdef LEKSAH_WITH_YI forwardCharsC (YiEditorIter i) n = transformYiIter i $ Yi.rightN n #endif @@ -757,12 +810,13 @@ case mbLimit of Just (GtkEditorIter limit) -> Just limit Nothing -> Nothing-#ifdef YI+#ifdef LEKSAH_WITH_YI _ -> fail "Mismatching TextEditor types in forwardFindChar" #endif -#ifdef YI-forwardFindCharC (YiEditorIter i) pred mbLimit = return Nothing -- TODO+#ifdef LEKSAH_WITH_YI+forwardFindCharC (YiEditorIter i) pred mbLimit = tryTransformYiIter i $+ Yi.doUntilB_ (pred <$> Yi.readB) Yi.rightB #endif forwardSearch :: EditorIter@@ -776,78 +830,83 @@ case mbLimit of Just (GtkEditorIter limit) -> Just limit Nothing -> Nothing-#ifdef YI+#ifdef LEKSAH_WITH_YI _ -> fail "Mismatching TextEditor types in forwardSearch" #endif -#ifdef YI+#ifdef LEKSAH_WITH_YI forwardSearch (YiEditorIter i) str pred mbLimit = return Nothing -- TODO #endif forwardToLineEndC :: EditorIter -> IDEM EditorIter forwardToLineEndC (GtkEditorIter i) = transformGtkIter i Gtk.textIterForwardToLineEnd-#ifdef YI+#ifdef LEKSAH_WITH_YI forwardToLineEndC (YiEditorIter i) = transformYiIter i Yi.moveToEol #endif forwardWordEndC :: EditorIter -> IDEM (Maybe EditorIter) forwardWordEndC (GtkEditorIter i) = transformGtkIterMaybe i Gtk.textIterForwardWordEnd-#ifdef YI-forwardWordEndC (YiEditorIter i) = return Nothing -- TODO+#ifdef LEKSAH_WITH_YI+forwardWordEndC (YiEditorIter i@(Yi.Iter b p)) = withYiIter i $ do+ Yi.nextWordB+ newPoint <- Yi.pointB+ if p == newPoint+ then return Nothing+ else return . Just $ mkYiIter' b newPoint #endif getChar :: EditorIter -> IDEM (Maybe Char) getChar (GtkEditorIter i) = liftIO $ Gtk.textIterGetChar i-#ifdef YI+#ifdef LEKSAH_WITH_YI getChar (YiEditorIter i) = withYiIter i Yi.readCharB #endif getCharsInLine :: EditorIter -> IDEM Int getCharsInLine (GtkEditorIter i) = liftIO $ Gtk.textIterGetCharsInLine i-#ifdef YI+#ifdef LEKSAH_WITH_YI getCharsInLine (YiEditorIter i) = withYiIter i $ length <$> Yi.readLnB #endif getLine :: EditorIter -> IDEM Int getLine (GtkEditorIter i) = liftIO $ Gtk.textIterGetLine i-#ifdef YI+#ifdef LEKSAH_WITH_YI getLine (YiEditorIter i) = withYiIter i Yi.curLn #endif getLineOffset :: EditorIter -> IDEM Int getLineOffset (GtkEditorIter i) = liftIO $ Gtk.textIterGetLineOffset i-#ifdef YI+#ifdef LEKSAH_WITH_YI getLineOffset (YiEditorIter i) = withYiIter i Yi.curCol #endif getOffset :: EditorIter -> IDEM Int getOffset (GtkEditorIter i) = liftIO $ Gtk.textIterGetOffset i-#ifdef YI+#ifdef LEKSAH_WITH_YI getOffset (YiEditorIter (Yi.Iter _ (Yi.Point o))) = return o #endif isStart :: EditorIter -> IDEM Bool isStart (GtkEditorIter i) = liftIO $ Gtk.textIterIsStart i-#ifdef YI+#ifdef LEKSAH_WITH_YI isStart (YiEditorIter i) = withYiIter i Yi.atSof #endif isEnd :: EditorIter -> IDEM Bool isEnd (GtkEditorIter i) = liftIO $ Gtk.textIterIsEnd i-#ifdef YI+#ifdef LEKSAH_WITH_YI isEnd (YiEditorIter i) = withYiIter i Yi.atEof #endif iterEqual :: EditorIter -> EditorIter -> IDEM Bool iterEqual (GtkEditorIter i1) (GtkEditorIter i2) = liftIO $ Gtk.textIterEqual i1 i2-#ifdef YI+#ifdef LEKSAH_WITH_YI iterEqual (YiEditorIter (Yi.Iter _ p1)) (YiEditorIter (Yi.Iter _ p2)) = return $ p1 == p2 iterEqual _ _ = liftIO $ fail "Mismatching TextEditor types in iterEqual" #endif startsLine :: EditorIter -> IDEM Bool startsLine (GtkEditorIter i) = liftIO $ Gtk.textIterStartsLine i-#ifdef YI+#ifdef LEKSAH_WITH_YI startsLine (YiEditorIter i) = withYiIter i Yi.atSol #endif @@ -855,25 +914,25 @@ atEnd (GtkEditorIter i) = liftIO $ GtkEditorIter <$> do buffer <- Gtk.textIterGetBuffer i Gtk.textBufferGetEndIter buffer-#ifdef YI+#ifdef LEKSAH_WITH_YI atEnd (YiEditorIter (Yi.Iter b _)) = iterFromYiBuffer' b Yi.sizeB #endif atLine :: EditorIter -> Int -> IDEM EditorIter atLine (GtkEditorIter i) line = transformGtkIter i $ flip Gtk.textIterSetLine line-#ifdef YI+#ifdef LEKSAH_WITH_YI atLine (YiEditorIter i) line = transformYiIter i $ Yi.gotoLn line #endif atLineOffset :: EditorIter -> Int -> IDEM EditorIter atLineOffset (GtkEditorIter i) column = transformGtkIter i $ flip Gtk.textIterSetLineOffset column-#ifdef YI+#ifdef LEKSAH_WITH_YI atLineOffset (YiEditorIter i) column = transformYiIter i $ Yi.moveToColB column #endif atOffset :: EditorIter -> Int -> IDEM EditorIter atOffset (GtkEditorIter i) offset = transformGtkIter i $ flip Gtk.textIterSetOffset offset-#ifdef YI+#ifdef LEKSAH_WITH_YI atOffset (YiEditorIter (Yi.Iter b _)) offset = return $ YiEditorIter $ Yi.Iter b (Yi.Point offset) #endif @@ -881,7 +940,7 @@ atStart (GtkEditorIter i) = liftIO $ GtkEditorIter <$> do buffer <- Gtk.textIterGetBuffer i Gtk.textBufferGetEndIter buffer-#ifdef YI+#ifdef LEKSAH_WITH_YI atStart (YiEditorIter (Yi.Iter b _)) = return $ mkYiIter' b $ Yi.Point 0 #endif @@ -891,26 +950,26 @@ t <- Gtk.textTagNew (Just name) Gtk.textTagTableAdd tt t return $ GtkEditorTag t-#ifdef YI+#ifdef LEKSAH_WITH_YI newTag (YiEditorTagTable) name = return YiEditorTag -- TODO #endif lookupTag :: EditorTagTable -> String -> IDEM (Maybe EditorTag) lookupTag (GtkEditorTagTable tt) name = liftIO $ fmap (fmap GtkEditorTag) $ Gtk.textTagTableLookup tt name-#ifdef YI+#ifdef LEKSAH_WITH_YI lookupTag (YiEditorTagTable) name = return Nothing -- TODO #endif -- Tag background :: EditorTag -> Gtk.Color -> IDEM () background (GtkEditorTag t) color = liftIO $ Gtk.set t [Gtk.textTagBackground := colorHexString color]-#ifdef YI+#ifdef LEKSAH_WITH_YI background (YiEditorTag) color = return () -- TODO #endif underline :: EditorTag -> Gtk.Underline -> IDEM () underline (GtkEditorTag t) value = liftIO $ Gtk.set t [Gtk.textTagUnderline := value]-#ifdef YI+#ifdef LEKSAH_WITH_YI underline (YiEditorTag) value = return () -- TODO #endif @@ -921,7 +980,7 @@ liftIO $ do id1 <- sv `Gtk.afterFocusIn` \_ -> reflectIDE f ideR >> return False return [ConnectC id1]-#ifdef YI+#ifdef LEKSAH_WITH_YI afterFocusIn (YiEditorView v) f = do ideR <- ask liftIO $ do@@ -935,7 +994,7 @@ liftIO $ do id1 <- sb `Gtk.afterModifiedChanged` reflectIDE f ideR return [ConnectC id1]-#ifdef YI+#ifdef LEKSAH_WITH_YI afterModifiedChanged (YiEditorBuffer b) f = return [] -- TODO #endif @@ -953,7 +1012,7 @@ id2 <- sv `Gtk.onButtonRelease` \_ -> reflectIDE f ideR >> return False id3 <- sb `Gtk.afterEndUserAction` reflectIDE f ideR return [ConnectC id1, ConnectC id2, ConnectC id3]-#ifdef YI+#ifdef LEKSAH_WITH_YI afterMoveCursor (YiEditorView v) f = return [] -- TODO #endif @@ -967,7 +1026,7 @@ id1 <- sv `Gtk.afterToggleOverwrite` reflectIDE f ideR #endif return [ConnectC id1]-#ifdef YI+#ifdef LEKSAH_WITH_YI afterToggleOverwrite (YiEditorView v) f = return [] -- TODO #endif @@ -979,7 +1038,7 @@ liftIO $ do id1 <- sv `Gtk.onButtonPress` \event -> reflectIDE (f event) ideR return [ConnectC id1]-#ifdef YI+#ifdef LEKSAH_WITH_YI onButtonPress (YiEditorView v) f = do ideR <- ask liftIO $ do@@ -995,7 +1054,7 @@ liftIO $ do id1 <- sv `Gtk.onButtonRelease` \event -> reflectIDE (f event) ideR return [ConnectC id1]-#ifdef YI+#ifdef LEKSAH_WITH_YI onButtonRelease (YiEditorView v) f = do ideR <- ask liftIO $ do@@ -1008,8 +1067,11 @@ ideR <- ask (GtkEditorBuffer sb) <- getBuffer (GtkEditorView sv) liftIO $ do- id1 <- sb `Gtk.afterBufferInsertText` \iter text ->- if (all (\c -> (isAlphaNum c) || (c == '.') || (c == '_')) text)+ id1 <- sb `Gtk.afterBufferInsertText` \iter text -> do+ let isIdent a = isAlphaNum a || a == '\'' || a == '_' || a == '.'+ let isOp a = isSymbol a || a == ':' || a == '\\' || a == '*' || a == '/' || a == '-'+ || a == '!' || a == '@' || a == '%' || a == '&' || a == '?'+ if (all isIdent text) || (all isOp text) then do hasSel <- Gtk.textBufferHasSelection sb if not hasSel@@ -1028,7 +1090,7 @@ #endif id3 <- sv `Gtk.onButtonPress` \_ -> reflectIDE cancel ideR >> return False return [ConnectC id1]-#ifdef YI+#ifdef LEKSAH_WITH_YI onCompletion (YiEditorView v) start cancel = return [] -- TODO #endif @@ -1044,7 +1106,7 @@ keyVal <- Gtk.eventKeyVal liftIO $ reflectIDE (f name modifier keyVal) ideR return [ConnectC id1]-#ifdef YI+#ifdef LEKSAH_WITH_YI onKeyPress (YiEditorView v) f = do ideR <- ask liftIO $ do@@ -1068,7 +1130,7 @@ keyVal <- Gtk.eventKeyVal liftIO $ reflectIDE (f name modifier keyVal) ideR return [ConnectC id1]-#ifdef YI+#ifdef LEKSAH_WITH_YI onKeyRelease (YiEditorView v) f = do ideR <- ask liftIO $ do@@ -1087,7 +1149,7 @@ sv `Gtk.widgetAddEvents` [Gtk.ButtonReleaseMask] id1 <- sv `Gtk.onButtonRelease` \e -> when (controlIsPressed e) (reflectIDE f ideR) >> return False return [ConnectC id1]-#ifdef YI+#ifdef LEKSAH_WITH_YI onLookupInfo (YiEditorView v) f = do ideR <- ask liftIO $ do@@ -1106,7 +1168,7 @@ id1 <- sv `Gtk.onPopulatePopup` \menu -> reflectIDE (f menu) ideR #endif return [ConnectC id1]-#ifdef YI+#ifdef LEKSAH_WITH_YI onPopulatePopup (YiEditorView v) f = do ideR <- ask liftIO $ do
src/IDE/Workspaces.hs view
@@ -1,4 +1,4 @@-{-# OPTIONS_GHC -XScopedTypeVariables #-}+{-# LANGUAGE CPP, ScopedTypeVariables #-} ----------------------------------------------------------------------------- -- -- Module : IDE.Workspace@@ -16,6 +16,8 @@ module IDE.Workspaces ( workspaceNew , workspaceOpen+, workspaceTry+, workspaceTry_ , workspaceOpenThis , workspaceClose , workspaceClean@@ -25,23 +27,27 @@ , workspaceAddPackage' , workspaceRemovePackage , workspacePackageNew+, packageTry+, packageTry_ -, makePackage , backgroundMake-, calculateReverseDependencies+, makePackage+ ) where import IDE.Core.State import Control.Monad.Trans (liftIO) import Graphics.UI.Editor.Parameters (Parameter(..), (<<<-), paraName, emptyParams)-import Control.Monad (unless, when)+import Control.Monad (unless, when, liftM)+import Control.Monad.Reader (lift) import Data.Maybe (isJust,fromJust ) import IDE.Utils.GUIUtils (chooseFile, chooseSaveFile) import System.FilePath- ((</>), isAbsolute, dropFileName, makeRelative, dropExtension,- takeBaseName, addExtension, takeExtension)+ (takeFileName, (</>), isAbsolute, dropFileName, makeRelative,+ dropExtension, takeBaseName, addExtension, takeExtension,+ takeDirectory) import Text.PrinterParser (readFields, writeFields,@@ -52,15 +58,16 @@ FieldDescriptionS(..)) import qualified Text.PrettyPrint as PP (text) import Graphics.UI.Gtk- (widgetDestroy, dialogRun, messageDialogNew, Window(..))-import IDE.Pane.PackageEditor (packageNew', choosePackageFile)-import Data.List ((\\), foldl', nub, delete)+ (dialogSetDefaultResponse, windowWindowPosition, widgetDestroy,+ dialogRun, messageDialogNew, dialogAddButton, Window(..),+ widgetHide, DialogFlags(..))+import IDE.Pane.PackageEditor (packageNew', choosePackageFile, standardSetup)+import Data.List (delete) import IDE.Package- (packageConfig', getModuleTemplate, getPackageDescriptionAndPath,- buildPackage, packageInstall', packageClean, activatePackage,+ (getModuleTemplate, getPackageDescriptionAndPath, activatePackage, deactivatePackage, idePackageFromPath) import System.Directory- (createDirectoryIfMissing, doesFileExist, canonicalizePath)+ (getHomeDirectory, createDirectoryIfMissing, doesFileExist) import System.Time (getClockTime) import Graphics.UI.Gtk.Windows.MessageDialog (ButtonsType(..), MessageType(..))@@ -71,36 +78,35 @@ #endif import Control.Exception (SomeException(..)) import Control.Monad.Reader.Class (ask)-import Data.Map (Map(..))-import qualified Data.Map as Map- (lookup, empty, mapWithKey, fromList, map)-import Distribution.Package (pkgVersion, pkgName, Dependency(..))-import Distribution.Version (withinRange)-import qualified GHC.List as List (or)-import IDE.Pane.SourceBuffer- (fileOpenThis, belongsToPackage, fileCheckAll)+import qualified Data.Map as Map (empty)+import IDE.Pane.SourceBuffer (fileOpenThis, fileCheckAll, belongsToPackage) import qualified System.IO.UTF8 as UTF8 (writeFile)+import System.Glib.Attributes (AttrOp(..), set)+import Graphics.UI.Gtk.General.Enums (WindowPosition(..))+import Control.Applicative ((<$>))+import IDE.Build+import IDE.Utils.FileUtils(myCanonicalizePath) setWorkspace :: Maybe Workspace -> IDEAction setWorkspace mbWs = do- let mbRealWs = case mbWs of- Nothing -> Nothing- Just ws -> Just ws{wsReverseDeps = calculateReverseDependencies ws} mbOldWs <- readIDE workspace- modifyIDE_ (\ide -> ide{workspace = mbRealWs})- let pack = case mbRealWs of+ modifyIDE_ (\ide -> ide{workspace = mbWs})+ let packFile = case mbWs of Nothing -> Nothing- Just ws -> wsActivePack ws- let oldPack = case mbOldWs of+ Just ws -> wsActivePackFile ws+ let oldPackFile = case mbOldWs of Nothing -> Nothing- Just ws -> wsActivePack ws- when (pack /= oldPack) $- case pack of+ Just ws -> wsActivePackFile ws+ let mbPackages = case mbWs of+ Nothing -> Nothing+ Just ws -> Just (wsPackages ws)+ when (packFile /= oldPackFile) $+ case packFile of Nothing -> deactivatePackage- Just p -> activatePackage pack >> return ()+ Just p -> activatePackage (getPackage p (fromJust mbPackages)) >> return () mbPack <- readIDE activePack- let wsStr = case mbRealWs of+ let wsStr = case mbWs of Nothing -> "" Just ws -> wsName ws let txt = wsStr ++ " > " ++@@ -112,6 +118,11 @@ triggerEventIDE UpdateWorkspaceInfo return () +getPackage :: FilePath -> [IDEPackage] -> Maybe IDEPackage+getPackage fp packages =+ case filter (\ p -> ipdCabalFile p == fp) packages of+ [p] -> Just p+ l -> Nothing -- --------------------------------------------------------------------- -- This needs to be incremented, when the workspace format changes@@ -124,22 +135,26 @@ workspaceNew = do window <- getMainWindow mbFile <- liftIO $ do- chooseSaveFile window "New file for wokspace" Nothing+ chooseSaveFile window "New file for workspace" Nothing case mbFile of Nothing -> return ()- Just filePath ->- let realPath = if takeExtension filePath == leksahWorkspaceFileExtension- then filePath- else addExtension filePath leksahWorkspaceFileExtension- in do- cPath <- liftIO $ canonicalizePath realPath- let newWorkspace = emptyWorkspace {- wsName = takeBaseName cPath,- wsFile = cPath}- liftIO $ writeFields cPath newWorkspace workspaceDescr- workspaceOpenThis False (Just cPath)- return ()+ Just filePath -> workspaceNewHere filePath +workspaceNewHere :: FilePath -> IDEAction+workspaceNewHere filePath =+ let realPath = if takeExtension filePath == leksahWorkspaceFileExtension+ then filePath+ else addExtension filePath leksahWorkspaceFileExtension+ in do+ dir <- liftIO $ myCanonicalizePath realPath+ let cPath = dir </> takeFileName realPath+ newWorkspace = emptyWorkspace {+ wsName = takeBaseName cPath,+ wsFile = cPath}+ liftIO $ writeFields cPath newWorkspace workspaceDescr+ workspaceOpenThis False (Just cPath)+ return ()+ workspaceOpen :: IDEAction workspaceOpen = do window <- getMainWindow@@ -147,7 +162,59 @@ workspaceOpenThis True mbFilePath return () +workspaceTryQuiet :: WorkspaceM a -> IDEM (Maybe a)+workspaceTryQuiet f = do+ maybeWorkspace <- readIDE workspace+ case maybeWorkspace of+ Just ws -> liftM Just $ runWorkspace f ws+ Nothing -> do+ ideMessage Normal "No workspace open"+ return Nothing +workspaceTryQuiet_ :: WorkspaceM a -> IDEAction+workspaceTryQuiet_ f = workspaceTryQuiet f >> return ()++workspaceTry :: WorkspaceM a -> IDEM (Maybe a)+workspaceTry f = do+ maybeWorkspace <- readIDE workspace+ case maybeWorkspace of+ Just ws -> liftM Just $ runWorkspace f ws+ Nothing -> do+ mainWindow <- getMainWindow+ defaultWorkspace <- liftIO $ (</> "leksah.lkshw") <$> getHomeDirectory+ resp <- liftIO $ do+ defaultExists <- doesFileExist defaultWorkspace+ md <- messageDialogNew (Just mainWindow) [DialogModal] MessageQuestion ButtonsCancel (+ "You need to have a workspace open for this to work. "+ ++ "Choose ~/leksah.lkshw to "+ ++ (if defaultExists then "open workspace " else "create a workspace ")+ ++ defaultWorkspace)+ dialogAddButton md "_New Workspace" (ResponseUser 1)+ dialogAddButton md "_Open Workspace" (ResponseUser 2)+ dialogAddButton md "~/leksah.lkshw" (ResponseUser 3)+ dialogSetDefaultResponse md (ResponseUser 3)+ set md [ windowWindowPosition := WinPosCenterOnParent ]+ resp <- dialogRun md+ widgetHide md+ return resp+ case resp of+ ResponseUser 1 -> do+ workspaceNew+ workspaceTryQuiet f+ ResponseUser 2 -> do+ workspaceOpen+ workspaceTryQuiet f+ ResponseUser 3 -> do+ defaultExists <- liftIO $ doesFileExist defaultWorkspace+ if defaultExists+ then workspaceOpenThis True (Just defaultWorkspace)+ else workspaceNewHere defaultWorkspace+ workspaceTryQuiet f+ _ -> return Nothing++workspaceTry_ :: WorkspaceM a -> IDEAction+workspaceTry_ f = workspaceTry f >> return ()+ chooseWorkspaceFile :: Window -> IO (Maybe FilePath) chooseWorkspaceFile window = chooseFile window "Select leksah workspace file (.lkshw)" Nothing @@ -161,14 +228,20 @@ exists <- liftIO $ doesFileExist spath wantToLoadSession <- if exists && askForSession- then liftIO $ do- md <- messageDialogNew Nothing [] MessageQuestion ButtonsYesNo- $ "Load the session settings stored with this workspace?"- rid <- dialogRun md- widgetDestroy md- case rid of- ResponseYes -> return True- otherwise -> return False+ then do+ window <- getMainWindow+ liftIO $ do+ md <- messageDialogNew (Just window) [] MessageQuestion ButtonsNone+ $ "There are session settings stored with this workspace."+ dialogAddButton md "_Ignore Session" ResponseCancel+ dialogAddButton md "_Load Session" ResponseYes+ dialogSetDefaultResponse md ResponseYes+ set md [ windowWindowPosition := WinPosCenterOnParent ]+ rid <- dialogRun md+ widgetDestroy md+ case rid of+ ResponseYes -> return True+ otherwise -> return False else return False if wantToLoadSession then triggerEventIDE (LoadSession spath) >> return ()@@ -189,31 +262,28 @@ case oldWorkspace of Nothing -> return () Just ws -> do- let oldActivePack = wsActivePack ws+ let oldActivePackFile = wsActivePackFile ws triggerEventIDE (SaveSession ((dropExtension (wsFile ws)) ++ leksahSessionFileExtension)) addRecentlyUsedWorkspace (wsFile ws) setWorkspace Nothing- when (isJust oldActivePack) $ do+ when (isJust oldActivePackFile) $ do triggerEventIDE (Sensitivity [(SensitivityProjectActive, False), (SensitivityWorkspaceOpen, False)]) return () return () return () -workspacePackageNew :: IDEAction+workspacePackageNew :: WorkspaceAction workspacePackageNew = do- mbWs <- readIDE workspace- case mbWs of- Nothing -> ideMessage Normal "Needs an open workspace"- Just ws -> do- let path = dropFileName (wsFile ws)- packageNew' (Just path) (\fp -> do- window <- getMainWindow- workspaceAddPackage' fp >> return ()- mbPack <- idePackageFromPath fp- constructAndOpenMainModule mbPack- triggerEventIDE UpdateWorkspaceInfo >> return ())+ ws <- ask+ let path = dropFileName (wsFile ws)+ lift $ packageNew' (Just path) (\fp -> do+ window <- getMainWindow+ workspaceTry_ $ workspaceAddPackage' fp >> return ()+ mbPack <- idePackageFromPath fp+ constructAndOpenMainModule mbPack+ triggerEventIDE UpdateWorkspaceInfo >> return ()) constructAndOpenMainModule :: Maybe IDEPackage -> IDEAction constructAndOpenMainModule Nothing = return ()@@ -235,66 +305,98 @@ _ -> return () -workspaceAddPackage :: IDEAction+workspaceAddPackage :: WorkspaceAction workspaceAddPackage = do- mbWs <- readIDE workspace- case mbWs of- Nothing -> ideMessage Normal "Needs an open workspace"- Just ws -> do- let path = dropFileName (wsFile ws)- window <- getMainWindow- mbFilePath <- liftIO $ choosePackageFile window (Just path)- case mbFilePath of- Nothing -> return ()- Just fp -> workspaceAddPackage' fp >> return ()+ ws <- ask+ let path = dropFileName (wsFile ws)+ window <- lift getMainWindow+ mbFilePath <- liftIO $ choosePackageFile window (Just path)+ case mbFilePath of+ Nothing -> return ()+ Just fp -> workspaceAddPackage' fp >> return () -workspaceAddPackage' :: FilePath -> IDEM (Maybe IDEPackage)+workspaceAddPackage' :: FilePath -> WorkspaceM (Maybe IDEPackage) workspaceAddPackage' fp = do- mbWs <- readIDE workspace- cfp <- liftIO $ canonicalizePath fp- case mbWs of+ ws <- ask+ cfp <- liftIO $ myCanonicalizePath fp+ mbPack <- lift $ idePackageFromPath cfp+ case mbPack of+ Just pack -> do+ let dir = takeDirectory cfp+ b1 <- liftIO $ doesFileExist (dir </> "Setup.hs")+ b2 <- liftIO $ doesFileExist (dir </> "Setup.lhs")+ unless (b1 || b2) $ liftIO $ do+ sysMessage Normal "Setup.(l)hs does not exist. Writing Standard"+ writeFile (dir </> "Setup.lhs") standardSetup+ unless (elem cfp (map ipdCabalFile (wsPackages ws))) $ lift $+ writeWorkspace $ ws {wsPackages = pack : wsPackages ws,+ wsActivePackFile = Just (ipdCabalFile pack)}+ return (Just pack) Nothing -> return Nothing- Just ws -> do- mbPack <- idePackageFromPath cfp- case mbPack of- Just pack -> do- unless (elem cfp (map ipdCabalFile (wsPackages ws))) $- writeWorkspace $ ws {wsPackages = pack : wsPackages ws,- wsActivePack = Just pack}- return (Just pack)- Nothing -> return Nothing +packageTryQuiet :: PackageM a -> IDEM (Maybe a)+packageTryQuiet f = do+ maybePackage <- readIDE activePack+ case maybePackage of+ Just p -> liftM Just $ runPackage f p+ Nothing -> do+ ideMessage Normal "No active package"+ return Nothing -workspaceRemovePackage :: IDEPackage -> IDEAction+packageTryQuiet_ :: PackageM a -> IDEAction+packageTryQuiet_ f = packageTryQuiet f >> return ()++packageTry :: PackageM a -> IDEM (Maybe a)+packageTry f = do+ liftM (>>= id) $ workspaceTry $ do+ maybePackage <- lift $ readIDE activePack+ case maybePackage of+ Just p -> liftM Just $ lift $ runPackage f p+ Nothing -> do+ window <- lift $ getMainWindow+ resp <- liftIO $ do+ md <- messageDialogNew (Just window) [] MessageQuestion ButtonsCancel+ "You need to have an active package for this to work."+ dialogAddButton md "_New Package" (ResponseUser 1)+ dialogAddButton md "_Add Package" (ResponseUser 2)+ dialogSetDefaultResponse md (ResponseUser 2)+ set md [ windowWindowPosition := WinPosCenterOnParent ]+ resp <- dialogRun md+ widgetHide md+ return resp+ case resp of+ ResponseUser 1 -> do+ workspacePackageNew+ lift $ packageTryQuiet f+ ResponseUser 2 -> do+ workspaceAddPackage+ lift $ packageTryQuiet f+ _ -> return Nothing++packageTry_ :: PackageM a -> IDEAction+packageTry_ f = packageTry f >> return ()++workspaceRemovePackage :: IDEPackage -> WorkspaceAction workspaceRemovePackage pack = do- mbWs <- readIDE workspace- case mbWs of- Nothing -> return ()- Just ws -> do- when (elem pack (wsPackages ws)) $- writeWorkspace ws {wsPackages = delete pack (wsPackages ws)}- return ()+ ws <- ask+ when (elem pack (wsPackages ws)) $ lift $+ writeWorkspace ws {wsPackages = delete pack (wsPackages ws)}+ return () -workspaceActivatePackage :: IDEPackage -> IDEAction+workspaceActivatePackage :: IDEPackage -> WorkspaceAction workspaceActivatePackage pack = do- activatePackage (Just pack)- mbWs <- readIDE workspace- case mbWs of- Nothing -> return ()- Just ws -> do- when (elem pack (wsPackages ws)) $ do- writeWorkspace ws {wsActivePack = Just pack}- return ()- return ()+ ws <- ask+ lift $ activatePackage (Just pack)+ when (elem pack (wsPackages ws)) $ lift $ do+ writeWorkspace ws {wsActivePackFile = Just (ipdCabalFile pack)}+ return ()+ return () writeWorkspace :: Workspace -> IDEAction writeWorkspace ws = do timeNow <- liftIO getClockTime let newWs = ws {wsSaveTime = show timeNow, wsVersion = workspaceVersion,- wsActivePackFile = case wsActivePack ws of- Nothing -> Nothing- Just pack -> Just (ipdCabalFile pack), wsPackagesFiles = map ipdCabalFile (wsPackages ws)} setWorkspace $ Just newWs newWs' <- liftIO $ makePathesRelative newWs@@ -304,27 +406,25 @@ readWorkspace fp = do ws <- liftIO $ readFields fp workspaceDescr emptyWorkspace ws' <- liftIO $ makePathesAbsolute ws fp- activePack <- case wsActivePackFile ws' of- Nothing -> return Nothing- Just fp -> idePackageFromPath fp packages <- mapM idePackageFromPath (wsPackagesFiles ws')- return ws'{ wsActivePack = activePack, wsPackages = map fromJust $ filter isJust $ packages}+ return ws'{ wsPackages = map fromJust $ filter isJust $ packages} makePathesRelative :: Workspace -> IO Workspace makePathesRelative ws = do- wsFile' <- canonicalizePath (wsFile ws)+ wsFile' <- myCanonicalizePath (wsFile ws) wsActivePackFile' <- case wsActivePackFile ws of Nothing -> return Nothing Just fp -> do- nfp <- canonicalizePath fp+ nfp <- liftIO $ myCanonicalizePath fp return (Just (makeRelative (dropFileName wsFile') nfp))- wsPackagesFiles' <- mapM canonicalizePath (wsPackagesFiles ws)+ wsPackagesFiles' <- mapM myCanonicalizePath (wsPackagesFiles ws) let relativePathes = map (\p -> makeRelative (dropFileName wsFile') p) wsPackagesFiles' return ws {wsActivePackFile = wsActivePackFile', wsFile = wsFile', wsPackagesFiles = relativePathes} + makePathesAbsolute :: Workspace -> FilePath -> IO Workspace makePathesAbsolute ws bp = do- wsFile' <- canonicalizePath bp+ wsFile' <- myCanonicalizePath bp wsActivePackFile' <- case wsActivePackFile ws of Nothing -> return Nothing Just fp -> do@@ -335,8 +435,8 @@ where makeAbsolute basePath relativePath = if isAbsolute relativePath- then canonicalizePath relativePath- else canonicalizePath (basePath </> relativePath)+ then myCanonicalizePath relativePath+ else myCanonicalizePath (basePath </> relativePath) emptyWorkspace = Workspace { wsVersion = workspaceVersion@@ -344,10 +444,9 @@ , wsName = "" , wsFile = "" , wsPackages = []-, wsActivePack = Nothing , wsPackagesFiles = [] , wsActivePackFile = Nothing-, wsReverseDeps = Map.empty+, wsNobuildPack = [] } workspaceDescr :: [FieldDescriptionS Workspace]@@ -407,78 +506,29 @@ ------------------------ -- Workspace make --- | Calculates for every package a list of packages, that depends directly on it--- This is the reverse info from cabal, were we specify what a package depends on-calculateReverseDependencies :: Workspace -> Map IDEPackage [IDEPackage]-calculateReverseDependencies ws = Map.map nub $ foldl' calc mpacks packages- where- packages = wsPackages ws- mpacks = Map.fromList (map (\p -> (p,[])) packages)-- calc :: Map IDEPackage [IDEPackage] -> IDEPackage -> Map IDEPackage [IDEPackage]- calc theMap pack = Map.mapWithKey (addDeps (ipdDepends pack) pack ) theMap-- addDeps :: [Dependency] -> IDEPackage -> IDEPackage -> [IDEPackage] -> [IDEPackage]- addDeps dependencies pack pack2 revDeps = if depsMatch then pack : revDeps else revDeps- where- depsMatch = List.or (map (matchOne pack2) dependencies)- matchOne thePack (Dependency name versionRange) =- name == pkgName (ipdPackageId thePack)- && withinRange (pkgVersion (ipdPackageId thePack)) versionRange----- | Select a package which is not direct or indirect dependent on any other package-selectFirstReasonableTarget :: [IDEPackage] -> Map IDEPackage [IDEPackage] -> IDEPackage-selectFirstReasonableTarget [] _ = error "Workspaces>>selectFirstReasonableTarget: empty package list"-selectFirstReasonableTarget [p] _ = p-selectFirstReasonableTarget l revDeps =- case foldl' removeDeps l l of- hd:_ -> hd- [] -> error "Workspaces>>selectFirstReasonableTarget: no remaining"- where- removeDeps :: [IDEPackage] -> IDEPackage -> [IDEPackage]- removeDeps packs p = packs \\ allDeps p-- allDeps :: IDEPackage -> [IDEPackage]- allDeps p = case Map.lookup p revDeps of- Nothing -> []- Just list -> list ++ concatMap allDeps list--makePackages :: Bool -> Bool -> [IDEPackage] -> IDEAction-makePackages _ _ [] = return ()-makePackages isBackgroundBuild needConfigure packages = do- mbWs <- readIDE workspace- prefs' <- readIDE prefs- case mbWs of- Nothing -> return ()- Just ws -> do- let package = selectFirstReasonableTarget packages (wsReverseDeps ws)- if needConfigure- then packageConfig' package (\b ->- if b- then buildPackage isBackgroundBuild package (cont prefs' package ws)- else return ())- else buildPackage isBackgroundBuild package (cont prefs' package ws)- where- cont prefs' package ws res =- if res- then do- let deps = case Map.lookup package (wsReverseDeps ws) of- Nothing -> []- Just list -> list- -- install if backgroundLink is set or it is not a background build and either- -- AlwaysInstall is set or- -- deps are not empty- when ((not isBackgroundBuild || backgroundLink prefs') &&- ((not (null deps) && autoInstall prefs' == InstallLibs)- || autoInstall prefs' == InstallAlways))- $ packageInstall' package (cont2 deps package)- else return () -- don't continue, when their was an error- cont2 deps package res = do- when res $ do- let nextTargets = delete package $ nub $ packages ++ deps- makePackages isBackgroundBuild True nextTargets+workspaceClean :: WorkspaceAction+workspaceClean = do+ ws <- ask+ let settings = MakeSettings {+ msInstallMode = InstallNo,+ msIsSingleMake = False,+ msSaveAllBeforeBuild = False,+ msBackgroundBuild = False,+ msLinkingInBB = False}+ makePackages settings (wsPackages ws) MoClean +workspaceMake :: WorkspaceAction+workspaceMake = do+ ws <- ask+ settings <- lift $ do+ prefs' <- readIDE prefs+ return (MakeSettings {+ msInstallMode = autoInstall prefs',+ msIsSingleMake = False,+ msSaveAllBeforeBuild = saveAllBeforeBuild prefs',+ msBackgroundBuild = False,+ msLinkingInBB = False})+ makePackages settings (wsPackages ws) (MoComposed [MoConfigure,MoBuild,MoInstall]) backgroundMake :: IDEAction backgroundMake = catchIDE (do@@ -493,26 +543,28 @@ else return [] let isModified = not (null modifiedPacks) when isModified $ do- makePackages True False modifiedPacks+ let settings = MakeSettings {+ msInstallMode = autoInstall prefs,+ msIsSingleMake = False,+ msSaveAllBeforeBuild = saveAllBeforeBuild prefs,+ msBackgroundBuild = True,+ msLinkingInBB = True}+ workspaceTryQuiet_ $ makePackages settings modifiedPacks (MoComposed [MoBuild,MoInstall]) ) (\(e :: SomeException) -> sysMessage Normal (show e)) -makePackage :: IDEAction+makePackage :: PackageAction makePackage = do- activePack' <- readIDE activePack- case activePack' of- Nothing -> return ()- Just p -> makePackages False False [p]--workspaceClean = do- mbWs <- readIDE workspace- case mbWs of- Nothing -> return ()- Just ws -> mapM_ (packageClean . Just) (wsPackages ws)--workspaceMake = do- mbWs <- readIDE workspace+ p <- ask+ (mbWs,settings) <- lift $ do+ prefs' <- readIDE prefs+ ws <- readIDE workspace+ return (ws,MakeSettings {+ msInstallMode = autoInstall prefs',+ msIsSingleMake = False,+ msSaveAllBeforeBuild = saveAllBeforeBuild prefs',+ msBackgroundBuild = False,+ msLinkingInBB = False}) case mbWs of- Nothing -> return ()- Just ws -> makePackages False True (wsPackages ws)-+ Nothing -> sysMessage Normal "No workspace for build."+ Just ws -> lift $ runWorkspace (makePackages settings [p] (MoComposed [MoBuild,MoInstall])) ws
src/IDE/YiConfig.hs view
@@ -6,24 +6,35 @@ -} module IDE.YiConfig (- yiVimConfig+ defaultYiConfig+, Config+, Control+, ControlM+, YiM+, start+, runControl+, liftYi ) where +#ifdef LEKSAH_WITH_YI++import Data.List (reverse, isPrefixOf) import Yi.Prelude import Prelude () import Yi import Yi.Keymap.Vim-import Yi.Buffer.Indent (indentAsPreviousB)-import Yi.Keymap.Keys-import Yi.Misc (adjBlock) import qualified Yi.UI.Pango+import Yi.UI.Pango.Control -import Yi.Style.Library (darkBlueTheme)-import Data.List (isPrefixOf, reverse, replicate) import Control.Monad (replicateM_) +start yiConfig f =+ startControl yiConfig $ do+ yiControl <- getControl+ controlIO (f yiControl)+ -- Set soft tabs of 4 spaces in width. prefIndent :: Mode s -> Mode s prefIndent m = m {@@ -38,7 +49,7 @@ | modeName m == "haskell" = m { modeGetAnnotations = modeGetAnnotations emptyMode } | otherwise = m -yiVimConfig = defaultConfig+defaultYiConfig = defaultConfig { -- Use VTY as the default UI. startFrontEnd = Yi.UI.Pango.start,@@ -130,4 +141,21 @@ insertN " #-}" moveTo p +#else++data Config = Config+data Control = Control+data ControlM a = ControlM+data YiM a = YiM++defaultYiConfig :: Config+defaultYiConfig = Config+start :: Config -> (Control -> IO a) -> IO a+start yiConfig f = f Control+runControl :: ControlM a -> Control -> IO a+runControl = undefined+liftYi :: YiM a -> ControlM a+liftYi = undefined++#endif