diff --git a/data/candy.lkshc b/data/candy.lkshc --- a/data/candy.lkshc +++ b/data/candy.lkshc @@ -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 -- >>= - diff --git a/data/emacs.lkshk b/data/emacs.lkshk --- a/data/emacs.lkshk +++ b/data/emacs.lkshk @@ -5,7 +5,7 @@ --File -n -> FileNew "Opens a new empty buffer" +n -> FileNew "Creates a new haskell module" x/f -> FileOpen "Opens an existing file" x/s -> FileSave "Saves the current buffer" x/w -> FileSaveAs "Saves the current buffer as a new file" diff --git a/data/keymap.lkshk b/data/keymap.lkshk --- a/data/keymap.lkshk +++ b/data/keymap.lkshk @@ -1,14 +1,19 @@ --Default Keymap file for Leksah ---Allowed Modifiers are --- is the Windows key on PC keyboards +--Allowed Modifiers are +-- +--There are two versions of control so we can map them differently on OS X +-- is the Apple key on OS X +-- is the Control key on OS X +-- -- 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 -n -> FileNew "Opens a new empty buffer" +n -> FileNew "Creates a new haskell module" o -> FileOpen "Opens an existing file" --x/f -> FileOpen "Opens an existing file" @@ -22,7 +27,7 @@ w -> FileClose "Closes the current buffer" --x/k -> FileClose "Closes the current buffer" -F4 -> Quit "Quits this program" +q -> Quit "Quits this program" --x/c -> Quit "Quits this program" --Edit @@ -38,15 +43,15 @@ -> EditDelete a -> EditSelectAll "Select the whole text in the current buffer" -f -> EditFind "Search for a text string (Toggles the " +f -> EditFind "Search for a text string" F3 -> EditFindNext "Find the next occurence of the text string" F3 -> EditFindPrevious "Find the previous occurence of the text string" l -> EditGotoLine "Go to line with a known index" -Right -> EditComment "Add a line style comment to the selected lies" -Left -> EditUncomment "Remove a line style comment" +d -> EditComment "Add a line style comment to the selected lies" +d -> EditUncomment "Remove a line style comment" Right -> EditShiftRight "Shift right" Left -> EditShiftLeft "Shift Left" @@ -72,7 +77,7 @@ -> HelpAbout b -> BuildPackage -r -> AddAllImports +r -> ResolveErrors r -> RunPackage @@ -95,18 +100,18 @@ i -> AddAllImports -- "For the next to entries the modifier is mandatory" -Page_Up -> FlipUp "Switch to next pane in reverse recently used oder" -Page_Down -> FlipDown "Switch to next pane in recently used oder" +Page_Up -> FlipUp "Switch to next pane in reverse recently used oder" +Page_Down -> FlipDown "Switch to next pane in recently used oder" -space -> StartComplete "Initiate complete in a source buffer" +space -> StartComplete "Initiate complete in a source buffer" F6 -> DebugStep F7 -> DebugStepLocal F8 -> DebugStepModule F9 -> DebugContinue -Return -> ExecuteSelection +Return -> ExecuteSelection m -> UpdateMetadataCurrent - +p -> OpenDocu diff --git a/data/leksah.menu b/data/leksah.menu --- a/data/leksah.menu +++ b/data/leksah.menu @@ -1,7 +1,8 @@ - + + @@ -52,7 +53,7 @@ - + @@ -67,7 +68,6 @@ - @@ -95,9 +95,7 @@ - - @@ -204,4 +202,5 @@ + diff --git a/data/prefs.lkshp b/data/prefs.lkshp --- a/data/prefs.lkshp +++ b/data/prefs.lkshp @@ -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= diff --git a/data/prefscoll.lkshp b/data/prefscoll.lkshp --- a/data/prefscoll.lkshp +++ b/data/prefscoll.lkshp @@ -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 diff --git a/leksah.cabal b/leksah.cabal --- a/leksah.cabal +++ b/leksah.cabal @@ -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 diff --git a/main/Main.hs b/main/Main.hs new file mode 100644 --- /dev/null +++ b/main/Main.hs @@ -0,0 +1,26 @@ +{-# LANGUAGE CPP #-} +----------------------------------------------------------------------------- +-- +-- Module : Main +-- Copyright : (c) Juergen Nicklisch-Franken, Hamish Mackenzie +-- License : GNU-GPL +-- +-- Maintainer : +-- 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 + diff --git a/src/IDE/BufferMode.hs b/src/IDE/BufferMode.hs new file mode 100644 --- /dev/null +++ b/src/IDE/BufferMode.hs @@ -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) + + + + + diff --git a/src/IDE/Build.hs b/src/IDE/Build.hs new file mode 100644 --- /dev/null +++ b/src/IDE/Build.hs @@ -0,0 +1,225 @@ +{-# OPTIONS_GHC #-} +----------------------------------------------------------------------------- +-- +-- Module : IDE.Build +-- Copyright : (c) Juergen Nicklisch-Franken, Hamish Mackenzie +-- License : GNU-GPL +-- +-- Maintainer : +-- 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 + + + + + diff --git a/src/IDE/Command.hs b/src/IDE/Command.hs --- a/src/IDE/Command.hs +++ b/src/IDE/Command.hs @@ -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 () diff --git a/src/IDE/Completion.hs b/src/IDE/Completion.hs --- a/src/IDE/Completion.hs +++ b/src/IDE/Completion.hs @@ -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 diff --git a/src/IDE/Core/State.hs b/src/IDE/Core/State.hs --- a/src/IDE/Core/State.hs +++ b/src/IDE/Core/State.hs @@ -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) diff --git a/src/IDE/Core/Types.hs b/src/IDE/Core/Types.hs --- a/src/IDE/Core/Types.hs +++ b/src/IDE/Core/Types.hs @@ -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 diff --git a/src/IDE/Debug.hs b/src/IDE/Debug.hs --- a/src/IDE/Debug.hs +++ b/src/IDE/Debug.hs @@ -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 diff --git a/src/IDE/Find.hs b/src/IDE/Find.hs --- a/src/IDE/Find.hs +++ b/src/IDE/Find.hs @@ -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"]) diff --git a/src/IDE/ImportTool.hs b/src/IDE/ImportTool.hs --- a/src/IDE/ImportTool.hs +++ b/src/IDE/ImportTool.hs @@ -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" diff --git a/src/IDE/Keymap.hs b/src/IDE/Keymap.hs --- a/src/IDE/Keymap.hs +++ b/src/IDE/Keymap.hs @@ -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 diff --git a/src/IDE/Leksah.hs b/src/IDE/Leksah.hs --- a/src/IDE/Leksah.hs +++ b/src/IDE/Leksah.hs @@ -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" diff --git a/src/IDE/LogRef.hs b/src/IDE/LogRef.hs --- a/src/IDE/LogRef.hs +++ b/src/IDE/LogRef.hs @@ -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 diff --git a/src/IDE/Metainfo/Provider.hs b/src/IDE/Metainfo/Provider.hs --- a/src/IDE/Metainfo/Provider.hs +++ b/src/IDE/Metainfo/Provider.hs @@ -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 diff --git a/src/IDE/OSX.hs b/src/IDE/OSX.hs --- a/src/IDE/OSX.hs +++ b/src/IDE/OSX.hs @@ -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 diff --git a/src/IDE/Package.hs b/src/IDE/Package.hs --- a/src/IDE/Package.hs +++ b/src/IDE/Package.hs @@ -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) diff --git a/src/IDE/Pane/Errors.hs b/src/IDE/Pane/Errors.hs --- a/src/IDE/Pane/Errors.hs +++ b/src/IDE/Pane/Errors.hs @@ -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 diff --git a/src/IDE/Pane/Info.hs b/src/IDE/Pane/Info.hs --- a/src/IDE/Pane/Info.hs +++ b/src/IDE/Pane/Info.hs @@ -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 () diff --git a/src/IDE/Pane/Log.hs b/src/IDE/Pane/Log.hs --- a/src/IDE/Pane/Log.hs +++ b/src/IDE/Pane/Log.hs @@ -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 () diff --git a/src/IDE/Pane/Modules.hs b/src/IDE/Pane/Modules.hs --- a/src/IDE/Pane/Modules.hs +++ b/src/IDE/Pane/Modules.hs @@ -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 diff --git a/src/IDE/Pane/PackageEditor.hs b/src/IDE/Pane/PackageEditor.hs --- a/src/IDE/Pane/PackageEditor.hs +++ b/src/IDE/Pane/PackageEditor.hs @@ -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 $ "The following fields have invalid values: " + ++ eventText e ++ "" + 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) diff --git a/src/IDE/Pane/PackageFlags.hs b/src/IDE/Pane/PackageFlags.hs --- a/src/IDE/Pane/PackageFlags.hs +++ b/src/IDE/Pane/PackageFlags.hs @@ -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 ())] -- ------------------------------------------------------------ diff --git a/src/IDE/Pane/Preferences.hs b/src/IDE/Pane/Preferences.hs --- a/src/IDE/Pane/Preferences.hs +++ b/src/IDE/Pane/Preferences.hs @@ -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 $ "The following fields have invalid values: " + ++ eventText e ++ "" + 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 diff --git a/src/IDE/Pane/References.hs b/src/IDE/Pane/References.hs deleted file mode 100644 --- a/src/IDE/Pane/References.hs +++ /dev/null @@ -1,314 +0,0 @@ -{-# OPTIONS_GHC -XDeriveDataTypeable -XMultiParamTypeClasses -XTypeSynonymInstances #-} ------------------------------------------------------------------------------ --- --- Module : IDE.Pane.References --- Copyright : (c) Juergen Nicklisch-Franken, Hamish Mackenzie --- License : GNU-GPL --- --- Maintainer : --- 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 - - diff --git a/src/IDE/Pane/SourceBuffer.hs b/src/IDE/Pane/SourceBuffer.hs --- a/src/IDE/Pane/SourceBuffer.hs +++ b/src/IDE/Pane/SourceBuffer.hs @@ -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 diff --git a/src/IDE/Pane/Trace.hs b/src/IDE/Pane/Trace.hs --- a/src/IDE/Pane/Trace.hs +++ b/src/IDE/Pane/Trace.hs @@ -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 diff --git a/src/IDE/Pane/Variables.hs b/src/IDE/Pane/Variables.hs --- a/src/IDE/Pane/Variables.hs +++ b/src/IDE/Pane/Variables.hs @@ -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) diff --git a/src/IDE/Pane/Workspace.hs b/src/IDE/Pane/Workspace.hs --- a/src/IDE/Pane/Workspace.hs +++ b/src/IDE/Pane/Workspace.hs @@ -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 diff --git a/src/IDE/PaneGroups.hs b/src/IDE/PaneGroups.hs --- a/src/IDE/PaneGroups.hs +++ b/src/IDE/PaneGroups.hs @@ -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 () diff --git a/src/IDE/Session.hs b/src/IDE/Session.hs --- a/src/IDE/Session.hs +++ b/src/IDE/Session.hs @@ -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)) diff --git a/src/IDE/SourceCandy.hs b/src/IDE/SourceCandy.hs --- a/src/IDE/SourceCandy.hs +++ b/src/IDE/SourceCandy.hs @@ -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 + diff --git a/src/IDE/TextEditor.hs b/src/IDE/TextEditor.hs --- a/src/IDE/TextEditor.hs +++ b/src/IDE/TextEditor.hs @@ -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 diff --git a/src/IDE/Workspaces.hs b/src/IDE/Workspaces.hs --- a/src/IDE/Workspaces.hs +++ b/src/IDE/Workspaces.hs @@ -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 diff --git a/src/IDE/YiConfig.hs b/src/IDE/YiConfig.hs --- a/src/IDE/YiConfig.hs +++ b/src/IDE/YiConfig.hs @@ -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