leksah 0.8.0.4 → 0.8.0.6
raw patch · 31 files changed
+617/−443 lines, 31 filesdep +process-leksahdep −process
Dependencies added: process-leksah
Dependencies removed: process
Files
- data/prefs.lkshp +4/−2
- data/prefscoll.lkshp +4/−2
- leksah.cabal +3/−2
- src/IDE/Command.hs +25/−11
- src/IDE/Completion.hs +2/−3
- src/IDE/Core/State.hs +4/−0
- src/IDE/Core/Types.hs +8/−2
- src/IDE/Debug.hs +18/−105
- src/IDE/Find.hs +22/−1
- src/IDE/ImportTool.hs +2/−3
- src/IDE/Keymap.hs +4/−1
- src/IDE/Leksah.hs +31/−28
- src/IDE/LogRef.hs +26/−17
- src/IDE/Metainfo/Provider.hs +7/−6
- src/IDE/NotebookFlipper.hs +10/−0
- src/IDE/OSX.hs +0/−2
- src/IDE/Package.hs +65/−90
- src/IDE/Pane/Breakpoints.hs +1/−2
- src/IDE/Pane/Log.hs +18/−9
- src/IDE/Pane/Modules.hs +84/−83
- src/IDE/Pane/PackageEditor.hs +1/−2
- src/IDE/Pane/Preferences.hs +22/−14
- src/IDE/Pane/Search.hs +20/−1
- src/IDE/Pane/SourceBuffer.hs +14/−10
- src/IDE/Pane/Trace.hs +4/−3
- src/IDE/Pane/Workspace.hs +3/−4
- src/IDE/TextEditor.hs +68/−32
- src/IDE/Utils/GUIUtils.hs +6/−3
- src/IDE/Utils/ServerConnection.hs +3/−3
- src/IDE/Workspaces.hs +5/−2
- src/IDE/YiConfig.hs +133/−0
data/prefs.lkshp view
@@ -46,8 +46,10 @@ [] Maybe a directory for unpacking cabal packages: Just "~/.leksah-0.8/packageSources"-Maybe an URL to load prebuild metadata :- Just "http://www.leksah.org"+An URL to load prebuild metadata:+ "http://www.leksah.org"+A strategy for downloading prebuild metadata:+ RetrieveThenBuild Update metadata at startup: True Port number for server connection:
data/prefscoll.lkshp view
@@ -2,8 +2,10 @@ [] Maybe a directory for unpacking cabal packages: Just "~/.leksah-0.8/packageSources"-Maybe an URL to load prebuild metadata :- Just "http://www.leksah.org"+An URL to load prebuild metadata:+ "http://www.leksah.org"+A strategy for downloading prebuild metadata:+ RetrieveThenBuild Port number for server connection: 11111 End the server with last connection:
leksah.cabal view
@@ -1,5 +1,5 @@ name: leksah-version: 0.8.0.4+version: 0.8.0.6 cabal-version: >=1.6 build-type: Simple license: GPL@@ -80,12 +80,13 @@ if flag(yi) build-depends: yi >=0.6.1 cpp-options: -DYI+ other-modules: IDE.YiConfig build-depends: Cabal >=1.6.0.1, base >=4.0.0.0 && <= 5, binary >=0.5.0.0, bytestring >=0.9.0.1, containers >=0.2.0.0, directory >=1.0.0.2, filepath >=1.1.0.1, glib >=0.10, gtk >=0.10, gtksourceview2 >=0.10.0, mtl >=1.1.0.2, old-time >=1.0.0.1,- parsec >=2.1.0.1, pretty >=1.0.1.0, process >=1.0.1.0,+ parsec >=2.1.0.1, pretty >=1.0.1.0, process-leksah >=1.0.1.3, regex-tdfa ==1.1.*, regex-base ==0.93.*, utf8-string >=0.3.1.1, array >=0.2.0.0, time >=0.1, ltk >= 0.8 && <= 0.9, binary-shared >= 0.8 && <= 0.9, deepseq >= 1.1.0.0, hslogger >= 1.0.7, leksah-server >= 0.8 && <= 0.9, network >= 2.2 && <= 3.0
src/IDE/Command.hs view
@@ -32,7 +32,26 @@ ) where import Graphics.UI.Gtk-import Graphics.UI.Gtk.Types+ (containerAdd, windowAddAccelGroup, onKeyPress, boxPackEnd,+ boxPackStart, widgetSetName, vBoxNew, windowSetIconFromFile,+ Widget, Window, actionGroupGetAction, uiManagerGetActionGroups,+ Action, actionSetSensitive, iconFactoryAdd, iconSetNewFromPixbuf,+ pixbufNewFromFile, iconFactoryAddDefault, iconFactoryNew,+ dialogRun, aboutDialogSetAuthors, aboutDialogSetWebsite,+ aboutDialogSetLicense, aboutDialogSetComments,+ aboutDialogSetCopyright, aboutDialogSetVersion, aboutDialogSetName,+ aboutDialogNew, mainQuit, widgetHide, widgetShow,+ widgetSetSensitive, castToWidget, separatorMenuItemNew,+ containerGetChildren, Menu, widgetSetSizeRequest, toolbarSetStyle,+ toolbarSetIconSize, castToToolbar, castToMenuBar,+ uiManagerGetWidget, uiManagerGetAccelGroup, onActionActivate,+ actionNew, actionGroupAddActionWithAccel, actionToggled,+ toggleActionNew, uiManagerAddUiFromString,+ uiManagerInsertActionGroup, actionGroupNew, UIManager,+ widgetShowAll, menuItemSetSubmenu, widgetDestroy, widgetHideAll,+ menuItemGetSubmenu, menuShellAppend, onActivateLeaf,+ menuItemNewWithLabel, menuNew, Packing(..), ToolbarStyle(..),+ PositionType(..), on, IconSize(..)) import Control.Monad.Reader import System.FilePath import Data.Version@@ -469,7 +488,7 @@ triggerEventIDE (StatusbarChanged [CompartmentCommand accStr]) return ()) ideR) -getMenuAndToolbars :: UIManager -> IO (AccelGroup, MenuBar, Toolbar)+-- getMenuAndToolbars :: UIManager -> IO (AccelGroup, MenuBar, Toolbar) getMenuAndToolbars uiManager = do accGroup <- uiManagerGetAccelGroup uiManager mbMenu <- uiManagerGetWidget uiManager "/ui/menubar"@@ -531,10 +550,10 @@ castToWidget mi13, castToWidget mi14, castToWidget mi141, castToWidget mi15] let otherEntries = [castToWidget mi2, castToWidget mi3]- isInterpreting' <- (reflectIDE isInterpreting ideR)+ -- isInterpreting' <- (reflectIDE isInterpreting ideR) selected <- (reflectIDE selectedText ideR)- unless isInterpreting'- $ mapM_ (\w -> widgetSetSensitive w False) (interpretingEntries ++ interpretingSelEntries)+-- unless isInterpreting'+-- $ mapM_ (\w -> widgetSetSensitive w False) (interpretingEntries ++ interpretingSelEntries) -- unless (isJust selected) -- $ mapM_ (\w -> widgetSetSensitive w False) (otherEntries ++ interpretingSelEntries) mapM_ widgetShow interpretingEntries@@ -610,12 +629,7 @@ getActionsFor SensitivityError = getActionsFor' ["NextError", "PreviousError"] getActionsFor SensitivityEditor = getActionsFor' ["EditUndo", "EditRedo", "EditGotoLine" ,"EditComment", "EditUncomment", "EditShiftLeft", "EditShiftRight"]-getActionsFor SensitivityInterpreting = getActionsFor' ["QuitDebugger" , "ExecuteSelection",- "DebugSetBreakpoint", "ShowNextBreakpoint", "ShowPreviousBreakpoint", "DebugDeleteAllBreakpoints",- "DebugContinue", "DebugAbandon", "DebugStop", "DebugStep", "DebugStepExpression", "DebugStepLocal",- "DebugStepModule", "DebugTrace", "DebugTraceExpression", "DebugHistory", "DebugBack", "DebugForward",- "DebugForce", "DebugPrint", "DebugSimplePrint", "ShowBindings", "ShowBreakpoints", "ShowContext",- "ShowLoadedModules", "ShowPackages", "ShowLanguages", "DebugInformation", "DebugKind", "DebugType"]+getActionsFor SensitivityInterpreting = getActionsFor' ["QuitDebugger"] getActionsFor SensitivityWorkspaceOpen = return [] --TODO add here getActionsFor' :: [String] -> IDEM[Action]
src/IDE/Completion.hs view
@@ -89,7 +89,7 @@ column <- liftIO $ treeViewColumnNew liftIO $ set column [- treeViewColumnSizing := TreeViewColumnAutosize,+ treeViewColumnSizing := TreeViewColumnFixed, treeViewColumnMinWidth := 800] -- OSX does not like it if there is no hscroll liftIO $ treeViewAppendColumn tree column renderer <- liftIO $ cellRendererTextNew@@ -99,8 +99,7 @@ liftIO $ set tree [treeViewHeadersVisible := False] descriptionBuffer <- newGtkBuffer Nothing ""- descriptionView <- newView descriptionBuffer- setFont descriptionView $ textviewFont prefs+ descriptionView <- newView descriptionBuffer (textviewFont prefs) setStyle descriptionBuffer $ sourceStyle prefs descriptionScrolledWindow <- getScrolledWindow descriptionView
src/IDE/Core/State.hs view
@@ -63,6 +63,7 @@ #ifdef YI , liftYiControl+, liftYi #endif , module IDE.Core.Types@@ -296,6 +297,9 @@ liftYiControl f = do control <- readIDE yiControl liftIO $ Yi.runControl f control++liftYi :: Yi.YiM a -> IDEM a+liftYi = liftYiControl . Yi.liftYi #endif
src/IDE/Core/Types.hs view
@@ -86,10 +86,14 @@ import Data.Map (Map(..)) import Data.Set (Set(..)) import Distribution.ModuleName (ModuleName(..))+#if MIN_VERSION_gtk(0,10,5)+import Graphics.UI.Gtk.Gdk.EventM (Modifier(..))+#else import Graphics.UI.Gtk.Gdk.Enums (Modifier(..))+#endif import System.Time (ClockTime(..)) import Distribution.Simple (Extension(..))-import System.Process (ProcessHandle(..))+import IDE.System.Process (ProcessHandle(..)) import IDE.Utils.Tool (ToolState(..)) import Data.IORef (writeIORef, readIORef, IORef(..)) import Numeric (showHex)@@ -97,6 +101,7 @@ (EventSelector(..), EventSource(..), Event(..)) import System.FilePath ((</>)) import IDE.Core.CTypes+import IDE.StrippedPrefs(RetrieveStrategy) import System.IO (Handle) -- ---------------------------------------------------------------------@@ -356,7 +361,8 @@ , serverPort :: Int , sourceDirectories :: [FilePath] , unpackDirectory :: Maybe FilePath- , retreiveURL :: Maybe String+ , retrieveURL :: String+ , retrieveStrategy :: RetrieveStrategy , endWithLastConn :: Bool } deriving(Eq,Show)
src/IDE/Debug.hs view
@@ -17,9 +17,9 @@ module IDE.Debug (- executeDebugCommand-, debugCommand+ debugCommand , debugCommand'+, debugToggled , debugQuit , debugExecuteSelection , debugExecuteAndShowSelection@@ -60,39 +60,14 @@ , debugKind , debugType -, interactiveFlags , debugSetPrintEvldWithShow , debugSetBreakOnException , debugSetBreakOnError , debugSetPrintBindResult ) where -#if defined(mingw32_HOST_OS) || defined(__MINGW32__)--- import System.Process (getProcessExitCode, ProcessHandle(..))--- import Data.Maybe (isNothing)-import GHC.ConsoleHandler (Handler(..), installHandler)-import System.Win32- (-- th32SnapEnumProcesses,- DWORD(..),- cTRL_BREAK_EVENT,- generateConsoleCtrlEvent)- -- tH32CS_SNAPPROCESS,- -- withTh32Snap)-import System.Process.Internals- (withProcessHandle, ProcessHandle__(..))-import Control.Concurrent.MVar (tryTakeMVar)-#else-import System.Posix- (sigINT,- installHandler,- signalProcessGroup,- getProcessGroupID)-import System.Posix.Signals (Handler(..))-#endif- import Control.Monad.Reader import IDE.Core.State-import IDE.Utils.Tool import IDE.LogRef import Control.Exception (SomeException(..)) import IDE.Pane.SourceBuffer@@ -102,30 +77,11 @@ import Distribution.Text (display) import IDE.Pane.Log (appendLog) import Data.List (isSuffixOf)---#if defined(mingw32_HOST_OS) || defined(__MINGW32__)-foreign import stdcall unsafe "winbase.h GetCurrentProcessId"- c_GetCurrentProcessId :: IO DWORD--foreign import stdcall unsafe "winbase.h GetProcessId"- c_GetProcessId :: DWORD -> IO DWORD-#endif--executeDebugCommand :: String -> ([ToolOutput] -> IDEAction) -> IDEAction-executeDebugCommand command handler = do- maybeGhci <- readIDE ghciState- case maybeGhci of- Just ghci -> do- triggerEventIDE (StatusbarChanged [CompartmentState command, CompartmentBuild True])- reifyIDE $ \ideR -> do- executeGhciCommand ghci command $ \output ->- reflectIDE (do- handler output- triggerEventIDE (StatusbarChanged [CompartmentState "", CompartmentBuild False])- return ()- ) ideR- _ -> sysMessage Normal "Debugger not running"+import IDE.System.Process (interruptProcessGroup)+import IDE.Utils.GUIUtils (getDebugToggled)+import IDE.Package (debugStart, executeDebugCommand, printBindResultFlag, breakOnErrorFlag,+ breakOnExceptionFlag, printEvldWithShowFlag)+import IDE.Utils.Tool (ToolOutput(..), toolProcess) debugCommand :: String -> ([ToolOutput] -> IDEAction) -> IDEAction debugCommand command handler = debugCommand' command@@ -133,13 +89,20 @@ handler to triggerEventIDE VariablesChanged return ())--- | Comment3+ debugCommand' :: String -> ([ToolOutput] -> IDEAction) -> IDEAction debugCommand' command handler = do ideR <- ask catchIDE (executeDebugCommand command handler) (\(e :: SomeException) -> putStrLn (show e)) +debugToggled :: IDEAction+debugToggled = do+ toggled <- getDebugToggled+ if toggled+ then debugStart+ else debugQuit+ debugQuit :: IDEAction debugQuit = debugCommand ":quit" logOutput @@ -202,40 +165,11 @@ debugStop :: IDEAction-#if defined(mingw32_HOST_OS) || defined(__MINGW32__) debugStop = do maybeGhci <- readIDE ghciState- case maybeGhci of- Just ghci -> do- liftIO $ do- maybeProcess <- tryTakeMVar (toolProcess ghci)- processGroupId <- case maybeProcess of- Just h -> do- withProcessHandle h (\h2 -> do- case h2 of- OpenHandle oh -> do- pid <- c_GetProcessId oh- return (h2, pid)- _ -> return (h2, 0))- _ -> return 0- old <- installHandler Ignore- putStrLn $ show processGroupId- generateConsoleCtrlEvent cTRL_BREAK_EVENT processGroupId- installHandler old- return ()- Nothing -> return ()-#else-debugStop = do- maybeGhci <- readIDE ghciState- case maybeGhci of- Just ghci -> liftIO $ do- group <- getProcessGroupID- old_int <- installHandler sigINT Ignore Nothing- signalProcessGroup sigINT group- installHandler sigINT old_int Nothing- return ()+ liftIO $ case maybeGhci of+ Just ghci -> toolProcess ghci >>= interruptProcessGroup Nothing -> return ()-#endif debugContinue :: IDEAction debugContinue = do@@ -357,6 +291,7 @@ -> appendLog log (line ++ "\n") LogTag ToolOutput line -> appendLog log (line ++ "\n") InfoTag ToolError line -> appendLog log (line ++ "\n") ErrorTag+ ToolPrompt -> defaultLineLogger' log output ToolExit _ -> appendLog log "X--X--X ghci process exited unexpectedly X--X--X" FrameTag return () @@ -415,28 +350,6 @@ ref <- ask return () Nothing -> ideMessage Normal "Please select module file in the editor"--interactiveFlag :: String -> Bool -> String-interactiveFlag name f = (if f then "-f" else "-fno-") ++ name--printEvldWithShowFlag :: Bool -> String-printEvldWithShowFlag = interactiveFlag "print-evld-with-show"--breakOnExceptionFlag :: Bool -> String-breakOnExceptionFlag = interactiveFlag "break-on-exception"--breakOnErrorFlag :: Bool -> String-breakOnErrorFlag = interactiveFlag "break-on-error"--printBindResultFlag :: Bool -> String-printBindResultFlag = interactiveFlag "print-bind-result"--interactiveFlags :: Prefs -> [String]-interactiveFlags prefs =- (printEvldWithShowFlag $ printEvldWithShow prefs)- : (breakOnExceptionFlag $ breakOnException prefs)- : (breakOnErrorFlag $ breakOnError prefs)- : [printBindResultFlag $ printBindResult prefs] debugSet :: (Bool -> String) -> Bool -> IDEAction debugSet flag value = do
src/IDE/Find.hs view
@@ -34,7 +34,28 @@ ) where -import Graphics.UI.Gtk hiding (get)+import Graphics.UI.Gtk+ (toggleToolButtonSetActive, castToToggleToolButton,+ toggleToolButtonGetActive, castToBin, binGetChild, widgetGetName,+ containerGetChildren, listStoreGetValue, treeModelGetPath,+ TreeIter, ListStore, widgetModifyText, widgetModifyBase,+ toolbarChildHomogeneous, afterEntryActivate, spinButtonSetRange,+ afterFocusIn, onEntryActivate, afterKeyPress, afterDeleteText,+ afterInsertText, treeModelGetValue, matchSelected,+ entryCompletionSetMatchFunc, cellText, cellLayoutSetAttributes,+ cellLayoutPackStart, cellRendererTextNew, entryCompletionModel,+ entrySetCompletion, entryCompletionNew, makeColumnIdString,+ customStoreSetColumn, listStoreNew, toolItemSetExpand,+ toolButtonSetLabel, toggleToolButtonNew, entryNew, tooltipsSetTip,+ onToolButtonClicked, Widget, toolButtonNew, separatorToolItemNew,+ labelNew, containerAdd, widgetSetName, spinButtonNewWithRange,+ toolItemNew, toolbarInsert, toolButtonNewFromStock,+ toolbarSetIconSize, toolbarSetStyle, tooltipsNew, toolbarNew,+ Toolbar, widgetGrabFocus, widgetShowAll, widgetHideAll,+ listStoreAppend, listStoreClear, entrySetText, spinButtonSetValue,+ listStoreToList, castToEntry, entryGetText, castToSpinButton,+ spinButtonGetValueAsInt, StateType(..), ToolbarStyle(..),+ IconSize(..), AttrOp(..), set, on, Color(..)) import Graphics.UI.Gtk.Gdk.Events import Control.Monad.Reader
src/IDE/ImportTool.hs view
@@ -49,7 +49,6 @@ import qualified Text.ParserCombinators.Parsec.Token as P (operator, dot, identifier, symbol, lexeme, whiteSpace, makeTokenParser)-import Debug.Trace (trace) import Graphics.UI.Gtk.Gdk.Events (Event(..)) import Control.Monad.Trans (liftIO) @@ -127,11 +126,11 @@ getScopeForActiveBuffer = do mbActiveBuf <- maybeActiveBuf case mbActiveBuf of- Nothing -> trace "getScopeForActiveBuffer: no activeBuffer" $ return Nothing+ Nothing -> return Nothing Just buf -> do mbPackage <- belongsToPackage buf case mbPackage of- Nothing -> trace "getScopeForActiveBuffer: no package" $ return Nothing+ Nothing -> return Nothing Just pack -> getPackageImportInfo pack addImport' :: NotInScopeParseResult -> FilePath -> Descr -> [Descr] -> ((Bool,[Descr]) -> IDEAction) -> IDEAction
src/IDE/Keymap.hs view
@@ -168,8 +168,11 @@ try $symbol2 "<alt>" return Alt <|> do- try $symbol2 "<apple>"+ try $symbol2 "<super>" return Super+ <|> do+ try $symbol2 "<meta>"+ return Meta <|> do try $symbol2 "<compose>" return Hyper
src/IDE/Leksah.hs view
@@ -35,8 +35,8 @@ #endif #ifdef YI-import qualified Yi as Yi import qualified Yi.UI.Pango.Control as Yi+import IDE.YiConfig #endif import Paths_leksah@@ -53,17 +53,17 @@ import IDE.Pane.SourceBuffer import IDE.Find import Graphics.UI.Editor.Composite (filesEditor, maybeEditor)-import Graphics.UI.Editor.Simple (fileEditor, intEditor, stringEditor, boolEditor)+import Graphics.UI.Editor.Simple+ (enumEditor, intEditor, stringEditor, boolEditor) import IDE.Metainfo.Provider (initInfo) import IDE.Workspaces (backgroundMake) import IDE.Utils.GUIUtils-import System.FilePath((</>)) import Network (withSocketsDo) import Control.Exception import System.Exit(exitFailure) import qualified IDE.StrippedPrefs as SP import IDE.Utils.Tool (runTool,toolline)-import System.Process(waitForProcess)+import IDE.System.Process(waitForProcess) #if defined(mingw32_HOST_OS) || defined(__MINGW32__) #else import qualified System.Posix as P@@ -80,11 +80,11 @@ deriving (Show,Eq) options :: [OptDescr Flag]-options = [Option ['v'] ["Version"] (NoArg VersionF)+options = [Option ['v'] ["version"] (NoArg VersionF) "Show the version number of ide"- , Option ['l'] ["LoadSession"] (ReqArg SessionN "NAME")+ , Option ['l'] ["loadSession"] (ReqArg SessionN "NAME") "Load session"- , Option ['h'] ["Help"] (NoArg Help)+ , Option ['h'] ["help"] (NoArg Help) "Display command line options" , Option ['e'] ["verbosity"] (ReqArg Verbosity "Verbosity") "One of DEBUG, INFO, NOTICE, WARNING, ERROR, CRITICAL, ALERT, EMERGENCY"]@@ -128,7 +128,7 @@ when (elem VersionF o) (sysMessage Normal $ "Leksah the Haskell IDE, version " ++ showVersion version) when (elem Help o)- (sysMessage Normal $ "Leksah the Haskell IDE, version " ++ usageInfo header options)+ (sysMessage Normal $ "Leksah the Haskell IDE " ++ usageInfo header options) dataDir <- getDataDir prefsPath <- getConfigFilePathForLoad standardPreferencesFilename Nothing dataDir prefs <- readPrefs prefsPath@@ -146,6 +146,11 @@ startGUI :: String -> Prefs -> Bool -> IO () startGUI sessionFilename iprefs isFirstStart = do+#ifdef YI+ Yi.startControl yiVimConfig $ do+ yiControl <- Yi.getControl+ Yi.controlIO $ do+#endif st <- unsafeInitGUIForThreadedRTS when rtsSupportsBoundThreads (sysMessage Normal "Linked with -threaded")@@ -184,9 +189,6 @@ , layout = (TerminalP Map.empty Nothing (-1) Nothing Nothing) , panePathFromNB = Map.empty }-#ifdef YI- yiControl <- Yi.newControl Yi.defaultVimConfig-#endif let ide = IDE { frameState = fs@@ -267,15 +269,12 @@ when (backgroundBuild currentPrefs) $ backgroundMake) ideR return True) priorityDefaultIdle 1000 reflectIDE (triggerEvent ideR (Sensitivity [(SensitivityInterpreting, False)])) ideR--- timeoutAddFull (do--- reflectIDE (postAsyncIDE (initInfo (modifyIDE_ (\ide -> ide{currentState = IsRunning})))) ideR--- return False) priorityDefault 100 mainGUI fDescription :: FilePath -> FieldDescription Prefs fDescription configPath = VFD emptyParams [ mkField- (paraName <<<- ParaName "Paths under which haskell sources may be found"+ (paraName <<<- ParaName "Paths under which haskell sources for packages may be found" $ paraDirection <<<- ParaDirection Vertical $ emptyParams) sourceDirectories@@ -285,14 +284,18 @@ (paraName <<<- ParaName "Maybe a directory for unpacking cabal packages" $ emptyParams) unpackDirectory (\b a -> a{unpackDirectory = b})- (maybeEditor ((fileEditor (Just (configPath </> "packageSources")) FileChooserActionSelectFolder- "Select folder for unpacking cabal packages"), emptyParams) True "Yes")+ (maybeEditor (stringEditor (\ _ -> True),emptyParams) True "") , mkField- (paraName <<<- ParaName "Maybe an URL to load prebuild metadata " $ emptyParams)- retreiveURL- (\b a -> a{retreiveURL = b})- (maybeEditor ((stringEditor (\ _ -> True)), emptyParams) True "Yes")+ (paraName <<<- ParaName "An URL to load prebuild metadata" $ emptyParams)+ retrieveURL+ (\b a -> a{retrieveURL = b})+ (stringEditor (\ _ -> True)) , mkField+ (paraName <<<- ParaName "A strategy for downloading prebuild 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})@@ -317,10 +320,10 @@ 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 metadata about your installed haskell packages.\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, but it only needs to run one time."))+ "This process may take a long time, so be patient.")) (widget, setInj, getExt,notifier) <- buildEditor (fDescription configDir) prefs boxPackStart vb label PackGrow 7 boxPackStart vb widget PackGrow 7@@ -328,10 +331,10 @@ widgetShowAll dialog response <- dialogRun dialog widgetHide dialog- widgetDestroy dialog case response of ResponseOk -> do mbNewPrefs <- extract prefs [getExt]+ widgetDestroy dialog case mbNewPrefs of Nothing -> do sysMessage Normal "No dialog results"@@ -343,17 +346,18 @@ SP.writeStrippedPrefs fp2 (SP.Prefs {SP.sourceDirectories = sourceDirectories newPrefs, SP.unpackDirectory = unpackDirectory newPrefs,- SP.retreiveURL = retreiveURL newPrefs,+ SP.retrieveURL = retrieveURL newPrefs,+ SP.retrieveStrategy = retrieveStrategy newPrefs, SP.serverPort = serverPort newPrefs, SP.endWithLastConn = endWithLastConn newPrefs}) firstBuild newPrefs- _ -> return ()+ _ -> widgetDestroy dialog firstBuild newPrefs = do dialog <- dialogNew vb <- dialogGetUpper dialog progressBar <- progressBarNew- progressBarSetText progressBar "Please wait while Leksah collects information about Haskell package on your system"+ progressBarSetText progressBar "Please wait while Leksah collects information about Haskell packages on your system" progressBarSetFraction progressBar 0.0 boxPackStart vb progressBar PackGrow 7 forkIO $ do@@ -368,7 +372,6 @@ return () where update pb to = do- putStrLn str when (isJust prog) $ postGUIAsync (progressBarSetFraction pb (fromJust prog)) where str = toolline to
src/IDE/LogRef.hs view
@@ -10,7 +10,7 @@ -- Portability : portable -- ----- | The packages methods of ide.+-- | -- --------------------------------------------------------------------------------- @@ -23,6 +23,7 @@ , markLogRefs , unmarkLogRefs , defaultLineLogger+, defaultLineLogger' , logOutputLines , logOutputLines_ , logOutput@@ -52,8 +53,8 @@ import System.Directory (canonicalizePath) import Data.List (stripPrefix, elemIndex, isPrefixOf) import Data.Maybe (catMaybes)-import Debug.Trace (trace) import System.Exit (ExitCode(..))+import System.Log.Logger (debugM) showSourceSpan :: LogRef -> String showSourceSpan = displaySrcSpan . logRefSrcSpan@@ -62,12 +63,12 @@ selectRef (Just ref) = do logRefs <- readIDE allLogRefs case elemIndex ref logRefs of- Nothing -> trace "no index" $ return ()+ Nothing -> liftIO $ debugM "leksah" "no index" >> return () Just index -> do mbBuf <- selectSourceBuf (logRefFullFilePath ref) case mbBuf of Just buf -> markRefInSourceBuf index buf ref True- Nothing -> trace "no buf" $ return ()+ Nothing -> liftIO $ debugM "leksah" "no buf" >> return () log :: IDELog <- getLog liftIO $ markErrorInLog log (logLines ref) selectRef Nothing = return ()@@ -279,7 +280,7 @@ data BuildError = BuildLine | EmptyLine- | ErrorLine SrcSpan String+ | ErrorLine SrcSpan LogRefType String | WarningLine String | OtherLine String @@ -296,8 +297,12 @@ span <- srcSpanParser char ':' whiteSpace+ refType <- try (do+ symbol "Warning:"+ return WarningRef)+ <|> return ErrorRef text <- many anyChar- return (ErrorLine span text))+ return (ErrorLine span refType text)) <|> try (do whiteSpace eof@@ -359,9 +364,10 @@ ToolInput line -> appendLog log (line ++ "\n") InputTag ToolOutput line -> appendLog log (line ++ "\n") LogTag ToolError line -> appendLog log (line ++ "\n") ErrorTag- ToolExit ExitSuccess -> appendLog log (take 40 (repeat '-') ++ "\n") FrameTag- ToolExit (ExitFailure 1) -> appendLog log (take 40 (repeat '=') ++ "\n") FrameTag- ToolExit (ExitFailure n) -> appendLog log (take 40 ("========== " ++ show n ++ " " ++ repeat '=') ++ "\n") FrameTag+ ToolPrompt -> appendLog log (concat (take 20 (repeat "- ")) ++ "-\n") FrameTag+ ToolExit ExitSuccess -> appendLog log (take 41 (repeat '-') ++ "\n") FrameTag+ ToolExit (ExitFailure 1) -> appendLog log (take 41 (repeat '=') ++ "\n") FrameTag+ ToolExit (ExitFailure n) -> appendLog log (take 41 ("========== " ++ show n ++ " " ++ repeat '=') ++ "\n") FrameTag logOutputLines :: (IDELog -> ToolOutput -> IDEM a) -> [ToolOutput] -> IDEM [a] logOutputLines lineLogger output = do@@ -398,12 +404,7 @@ where readAndShow :: [ToolOutput] -> IDERef -> IDELog -> Bool -> [LogRef] -> IO [LogRef] readAndShow [] _ log _ errs = do- let errorNum = length (filter isError errs)- let warnNum = length errs - errorNum- case errs of- [] -> defaultLineLogger' log (ToolExit ExitSuccess)- _ -> appendLog log ("----- " ++ show errorNum ++ " errors -- "- ++ show warnNum ++ " warnings -----\n") FrameTag+ appendLog log ("----- Leksah Error Please Report -----\n") FrameTag return errs readAndShow (output:remainingOutput) ideR log inError errs = do case output of@@ -426,8 +427,8 @@ (Left e,_) -> do sysMessage Normal (show e) readAndShow remainingOutput ideR log False errs- (Right ne@(ErrorLine span str),_) ->- readAndShow remainingOutput ideR log True ((LogRef span rootPath str (lineNr,lineNr) ErrorRef):errs)+ (Right ne@(ErrorLine span refType str),_) ->+ readAndShow remainingOutput ideR log True ((LogRef span rootPath 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@@ -453,6 +454,14 @@ ToolInput line -> do appendLog log (line ++ "\n") InputTag readAndShow remainingOutput ideR log inError errs+ ToolPrompt -> do+ let errorNum = length (filter isError errs)+ let warnNum = length errs - errorNum+ case errs of+ [] -> defaultLineLogger' log output+ _ -> appendLog log ("- - - " ++ show errorNum ++ " errors - "+ ++ show warnNum ++ " warnings - - -\n") FrameTag+ return errs ToolExit _ -> do let errorNum = length (filter isError errs) let warnNum = length errs - errorNum
src/IDE/Metainfo/Provider.hs view
@@ -10,8 +10,7 @@ -- Stability : provisional -- Portability : portable ----- | This module provides the infos collected by the extractor before--- and an info pane to present some of them to the user+-- | This module provides the infos collected by the server before -- --------------------------------------------------------------------------------- @@ -64,11 +63,12 @@ import Distribution.Text (display) import IDE.Core.Serializable () import Data.Map (Map(..))-import Debug.Trace import Control.Exception (SomeException(..), catch) import Prelude hiding(catch) import IDE.Utils.ServerConnection(doServerCommand) +trace a b = b+ -- --------------------------------------------------------------------- -- Updating metadata --@@ -77,7 +77,7 @@ -- | Update and initialize metadata for the world -- Called at startup -- initInfo :: IDEAction -> IDEAction-initInfo continuation = trace "init info called" $ do+initInfo continuation = do prefs <- readIDE prefs if collectAtStart prefs then do@@ -89,7 +89,8 @@ updateWorkspaceInfo' False $ \ _ -> do ideMessage Normal "Finished" triggerEventIDE (InfoChanged True) >> return ()- continuation++ trace "blah" $ continuation else do ideMessage Normal "Now loading metadata ..." loadSystemInfo@@ -137,7 +138,7 @@ packageIds let scope = foldr buildScope (PackScope Map.empty getEmptyDefaultScope) $ catMaybes packageList--- liftIO performGC+-- liftIO performGC modifyIDE_ (\ide -> ide{systemInfo = (Just (GenScopeC (addOtherToScope scope False)))}) return ()
src/IDE/NotebookFlipper.hs view
@@ -18,6 +18,16 @@ ) where import Graphics.UI.Gtk+ (treeViewSetCursor, treeViewGetCursor, treeModelIterNChildren,+ treeViewGetModel, treeViewRowActivated, treeViewGetColumn,+ widgetShowAll, windowWindowPosition, widgetDestroy, widgetHideAll,+ listStoreGetValue, onRowActivated, onKeyRelease,+ treeViewHeadersVisible, cellText, cellLayoutSetAttributes,+ treeViewColumnPackStart, cellRendererTextNew, treeViewAppendColumn,+ treeViewColumnNew, treeViewSetModel, listStoreNew, treeViewNew,+ containerAdd, frameNew, windowResizable, windowSetTransientFor,+ windowNewPopup, TreeViewClass, WindowPosition(..), signalDisconnect,+ AttrOp(..), set) import IDE.Core.State import Control.Monad.Trans (liftIO) import Graphics.UI.Gtk.Gdk.Events (Event(..))
src/IDE/OSX.hs view
@@ -1,4 +1,3 @@-{-# INCLUDE <igemacintegration/ige-mac-menu.h> #-} {-# LANGUAGE ForeignFunctionInterface #-} ----------------------------------------------------------------------------- --@@ -22,7 +21,6 @@ import Graphics.UI.Gtk import Foreign (nullPtr, withForeignPtr, Ptr(..)) import System.Glib (GObject(..))-import System.Glib.Types (toGObject) 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 ()
src/IDE/Package.hs view
@@ -45,7 +45,11 @@ , backgroundLinkToggled , debugStart-, debugToggled+, printBindResultFlag+, breakOnErrorFlag+, breakOnExceptionFlag+, printEvldWithShowFlag+, executeDebugCommand , choosePackageFile , idePackageFromPath@@ -62,7 +66,7 @@ import Control.Concurrent import System.Directory (setCurrentDirectory, doesFileExist) import Prelude hiding (catch)-import Data.Maybe (isJust, fromJust)+import Data.Maybe (isNothing, isJust, fromJust) import Control.Exception (SomeException(..), catch) import Paths_leksah @@ -74,44 +78,17 @@ import Distribution.Text (display) import IDE.Utils.FileUtils(getConfigFilePathForLoad) import IDE.LogRef-import IDE.Debug import MyMissing (replace) import Distribution.ModuleName (ModuleName(..)) import Data.List (isInfixOf, nub, foldl') import qualified System.IO.UTF8 as UTF8 (readFile) import IDE.Utils.Tool (ToolOutput(..), runTool, newGhci, ToolState(..))---#if defined(mingw32_HOST_OS) || defined(__MINGW32__)-import Data.Maybe (isNothing)-import System.Win32- (DWORD(..))-import System.Process (getProcessExitCode)-#else-import System.Posix- (getGroupProcessStatus,- sigINT,- installHandler,- signalProcessGroup,- getProcessGroupID)-import System.Posix.Signals (Handler(..))-import Foreign.C (Errno(..), getErrno)-#endif--- Leave at least one import ofter this #endif--- so the auto import tool does not add stuf insied the- import qualified Data.Set as Set (fromList) import qualified Data.Map as Map (empty) import System.Exit (ExitCode(..))---#if defined(mingw32_HOST_OS) || defined(__MINGW32__)-foreign import stdcall unsafe "winbase.h GetCurrentProcessId"- c_GetCurrentProcessId :: IO DWORD--foreign import stdcall unsafe "winbase.h GetProcessId"- c_GetProcessId :: DWORD -> IO DWORD-#endif+import Control.Applicative ((<$>))+import IDE.System.Process (getProcessExitCode, interruptProcessGroup)+import IDE.Utils.Tool (executeGhciCommand) #if MIN_VERSION_Cabal(1,8,0) myLibModules pd = case library pd of@@ -431,65 +408,20 @@ -- | Handling of Compiler errors -- isRunning :: IDEM Bool-#if defined(mingw32_HOST_OS) || defined(__MINGW32__) isRunning = do maybeProcess <- readIDE runningTool liftIO $ do case maybeProcess of Just process -> do- maybeExitCode <- getProcessExitCode process- return $ isNothing maybeExitCode+ isNothing <$> getProcessExitCode process Nothing -> return False--- Once we can interupt the build on windows, then something like this might be needed--- alreadyRunning <- liftIO $ do--- withTh32Snap tH32CS_SNAPPROCESS Nothing (\h -> do--- all <- th32SnapEnumProcesses h--- currentId <- c_GetCurrentProcessId--- return $ not $ null $ filter (\(_, _, parentId, _, _) -> parentId == currentId) all)-#else-isRunning = do- ideR <- ask- liftIO $ (do- group <- getProcessGroupID- status <- getGroupProcessStatus False False group- -- putStrLn $ "Status " ++ show status- case status of- Just _ -> reflectIDE isRunning ideR- Nothing -> return True)- `catch` (\(e :: IOError) -> do- Errno errno <- liftIO $ getErrno- -- putStrLn $ "Error " ++ show errno- return $ errno /= 10)-#endif interruptBuild :: IDEAction-#if defined(mingw32_HOST_OS) || defined(__MINGW32__) interruptBuild = do- -- I can't get this to work- --maybeProcess <- readIDE runningTool- --liftIO $ do- -- processGroupId <- case maybeProcess of- -- Just h -> do- -- withProcessHandle h (\h2 -> do- -- case h2 of- -- OpenHandle oh -> do- -- pid <- c_GetProcessId oh- -- return (h2, pid)- -- _ -> return (h2, 0))- -- _ -> return 0- -- old <- installHandler Ignore- -- putStrLn $ show processGroupId- -- generateConsoleCtrlEvent cTRL_BREAK_EVENT processGroupId- -- installHandler old- return ()-#else-interruptBuild = liftIO $ do- group <- getProcessGroupID- old_int <- installHandler sigINT Ignore Nothing- signalProcessGroup sigINT group- installHandler sigINT old_int Nothing- return ()-#endif+ maybeProcess <- readIDE runningTool+ liftIO $ case maybeProcess of+ Just h -> interruptProcessGroup h+ _ -> return () -- --------------------------------------------------------------------- -- | * Utility functions/procedures, that have to do with packages@@ -547,7 +479,7 @@ Nothing -> pd Just lib -> pd{library = Just (lib{libBuildInfo = addModToBuildInfo (libBuildInfo lib) moduleName})}- in npd1{executables = map+ in npd1{executables = map (\exe -> exe{buildInfo = addModToBuildInfo (buildInfo exe) moduleName}) (executables npd1)} in writePackageDescription (ipdCabalFile p) npd)@@ -572,6 +504,28 @@ -- | * Debug code that needs to use the package -- +interactiveFlag :: String -> Bool -> String+interactiveFlag name f = (if f then "-f" else "-fno-") ++ name++printEvldWithShowFlag :: Bool -> String+printEvldWithShowFlag = interactiveFlag "print-evld-with-show"++breakOnExceptionFlag :: Bool -> String+breakOnExceptionFlag = interactiveFlag "break-on-exception"++breakOnErrorFlag :: Bool -> String+breakOnErrorFlag = interactiveFlag "break-on-error"++printBindResultFlag :: Bool -> String+printBindResultFlag = interactiveFlag "print-bind-result"++interactiveFlags :: Prefs -> [String]+interactiveFlags prefs =+ (printEvldWithShowFlag $ printEvldWithShow prefs)+ : (breakOnExceptionFlag $ breakOnException prefs)+ : (breakOnErrorFlag $ breakOnError prefs)+ : [printBindResultFlag $ printBindResult prefs]+ debugStart :: IDEAction debugStart = catchIDE (do ideRef <- ask@@ -588,10 +542,12 @@ $ \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@@ -599,7 +555,9 @@ let modified = not (null modifiedPacks) prefs <- readIDE prefs when ((not modified) && (backgroundBuild prefs)) $ do- -- TODO Check with Hamish what this means.+ -- 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 ())@@ -610,12 +568,29 @@ return ()) (\(e :: SomeException) -> putStrLn (show e)) -debugToggled :: IDEAction-debugToggled = do- toggled <- getDebugToggled- if toggled- then debugStart- else debugQuit+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 ->+ reflectIDE (do+ handler output+ triggerEventIDE (StatusbarChanged [CompartmentState "", CompartmentBuild False])+ return ()+ ) ideR+ _ -> 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+ case resp of+ ResponseYes -> do+ debugStart+ executeDebugCommand command handler+ _ -> return () idePackageFromPath :: FilePath -> IDEM (Maybe IDEPackage) idePackageFromPath filePath = do
src/IDE/Pane/Breakpoints.hs view
@@ -33,7 +33,6 @@ debugDeleteBreakpoint, debugDeleteAllBreakpoints) import IDE.LogRef (showSourceSpan)-import Debug.Trace (trace) import Data.List (elemIndex) @@ -116,7 +115,7 @@ getSelectedBreakpoint :: TreeView -> TreeStore LogRef -> IO (Maybe LogRef)-getSelectedBreakpoint treeView treeStore = trace "Get selected breakpoint" $do+getSelectedBreakpoint treeView treeStore = do treeSelection <- treeViewGetSelection treeView paths <- treeSelectionGetSelectedRows treeSelection case paths of
src/IDE/Pane/Log.hs view
@@ -38,7 +38,7 @@ import Prelude hiding (catch) import Control.Exception hiding (try) import IDE.ImportTool (addImport, parseNotInScope, addAllImports)-import System.Process (runInteractiveProcess, ProcessHandle)+import IDE.System.Process (runInteractiveProcess, ProcessHandle) import Graphics.UI.Gtk (textBufferSetText, textViewScrollToMark, textBufferGetIterAtLineOffset, textViewScrollMarkOnscreen,@@ -48,18 +48,21 @@ widgetHide, widgetShowAll, menuShellAppend, onActivateLeaf, menuItemNewWithLabel, containerGetChildren, textIterGetLine, textViewGetLineAtY, textViewWindowToBufferCoords, widgetGetPointer,- onPopulatePopup, onButtonPress, afterFocusIn,+#if MIN_VERSION_gtk(0,10,5)+ on, populatePopup,+#else+ onPopulatePopup,+#endif+ onButtonPress, afterFocusIn, scrolledWindowSetShadowType, scrolledWindowSetPolicy, containerAdd, scrolledWindowNew, widgetModifyFont, fontDescriptionSetFamily, fontDescriptionNew, fontDescriptionFromString, textViewSetEditable, textTagBackground, textTagTableAdd, textTagForeground, textTagNew, textBufferGetTagTable, textBufferCreateMark, textBufferGetEndIter, textViewGetBuffer, textViewNew, Window, Notebook, castToWidget,- ScrolledWindow, TextView)-import System.Glib.Attributes (AttrOp(..), set)-import Graphics.UI.Gtk.General.Enums- (TextWindowType(..), ShadowType(..), PolicyType(..))-import System.Glib.MainLoop (priorityDefaultIdle, idleAdd)+ ScrolledWindow, TextView, Menu, AttrOp(..), set,+ TextWindowType(..), ShadowType(..), PolicyType(..),+ priorityDefaultIdle, idleAdd) -------------------------------------------------------------------------------@@ -152,7 +155,12 @@ (\_ -> do reflectIDE (makeActive buf) ideR ; return False) cid2 <- tv `onButtonPress` (\ b -> do reflectIDE (clicked b buf) ideR ; return False)- cid3 <- tv `onPopulatePopup` (populatePopup buf ideR)++#if MIN_VERSION_gtk(0,10,5)+ cid3 <- tv `on` populatePopup $ populatePopupMenu buf ideR+#else+ cid3 <- tv `onPopulatePopup` (populatePopupMenu buf ideR)+#endif return (Just buf,[ConnectC cid1, ConnectC cid2]) clicked :: Event -> IDELog -> IDEAction@@ -178,7 +186,8 @@ otherwise -> return () clicked _ _ = return () -populatePopup ideLog ideR menu = do+populatePopupMenu :: IDELog -> IDERef -> Menu -> IO ()+populatePopupMenu ideLog ideR menu = do items <- containerGetChildren menu res <- reflectIDE (do logRefs' <- readIDE allLogRefs
src/IDE/Pane/Modules.hs view
@@ -56,9 +56,10 @@ import Graphics.UI.Editor.Basics (eventPaneName,GUIEventSelector(..)) import qualified System.IO.UTF8 as UTF8 (writeFile) import IDE.Utils.GUIUtils (stockIdFromType)-import Debug.Trace import IDE.Metainfo.Provider (getSystemInfo, getWorkspaceInfo, getPackageInfo)+import System.Log.Logger (infoM)+import Default (Default(..)) -- | A modules pane description --@@ -67,7 +68,7 @@ outer :: VBox , paned :: HPaned , treeView :: TreeView-, treeStore :: TreeStore (String, [(ModuleDescr,PackageDescr)])+, treeStore :: TreeStore (String, Maybe (ModuleDescr,PackageDescr)) , descrView :: TreeView , descrStore :: TreeStore Descr , packageScopeB :: RadioButton@@ -133,12 +134,11 @@ mbTreeSelection <- getSelectionTree (treeView m) (treeStore m) mbFacetSelection <- getSelectionDescr (descrView m) (descrStore m) let mbs = (case mbTreeSelection of- Nothing -> Nothing- Just (_,[]) -> Nothing- Just (_,((md,_):_)) -> Just (modu $ mdModuleId md),- case mbFacetSelection of- Nothing -> Nothing- Just fw -> Just (dscName fw))+ Just (_,Just (md,_)) -> Just (modu $ mdModuleId md)+ otherwise -> Nothing,+ case mbFacetSelection of+ Nothing -> Nothing+ Just fw -> Just (dscName fw)) return (Just (ModulesState i sc mbs expander)) recoverState pp (ModulesState i sc@(scope,useBlacklist) se exp) = do nb <- getNotebook pp@@ -165,7 +165,7 @@ renderer <- cellRendererTextNew col <- treeViewColumnNew- treeViewColumnSetTitle col "Modules"+ treeViewColumnSetTitle col "Module" treeViewColumnSetSizing col TreeViewColumnAutosize treeViewColumnSetResizable col True treeViewColumnSetReorderable col True@@ -177,23 +177,26 @@ cellLayoutSetAttributes col renderer0 treeStore $ \row -> [ cellPixbufStockId :=- if null (snd row)- then ""- else if isJust (mdMbSourcePath (fst (head (snd row))))- then "ide_source"- else ""]+ case snd row of+ Nothing -> ""+ Just pair -> if isJust (mdMbSourcePath (fst pair))+ then "ide_source"+ else ""] renderer2 <- cellRendererTextNew col2 <- treeViewColumnNew- treeViewColumnSetTitle col2 "Packages"+ treeViewColumnSetTitle col2 "Package" treeViewColumnSetSizing col2 TreeViewColumnAutosize treeViewColumnSetResizable col2 True treeViewColumnSetReorderable col2 True treeViewAppendColumn treeView col2 cellLayoutPackStart col2 renderer2 True cellLayoutSetAttributes col2 renderer2 treeStore- $ \row -> [ cellText := (concat . intersperse ", ")- $ map (display . pdPackage . snd) (snd row)]+ $ \row -> [+ cellText := case snd row of+ Nothing -> ""+ Just pair -> (display . pdPackage . snd) pair]+ treeViewSetHeadersVisible treeView True treeViewSetEnableSearch treeView True treeViewSetSearchEqualFunc treeView (Just (treeViewSearch treeView treeStore))@@ -390,7 +393,7 @@ treePathFromNameArray Nothing _ _ = Nothing treeViewSearch :: TreeView- -> TreeStore (String, [(ModuleDescr,PackageDescr)])+ -> TreeStore (String, Maybe (ModuleDescr,PackageDescr)) -> String -> TreeIter -> IO Bool@@ -404,21 +407,22 @@ in when found $ do treeViewExpandRow treeView path False return ()- let str2 = case snd val of- [] -> fst val- (m,_):_ -> showPackModule (mdModuleId m)+ let str2 = case snd val of+ Just (mod,_) -> showPackModule (mdModuleId mod)+ Nothing -> "" let res = isInfixOf (map toLower string) (map toLower str2) return res searchInModSubnodes :: ModTree -> String -> Bool searchInModSubnodes tree str = not $ null- $ filter (\ val ->- let cstr = case snd val of- [] -> fst val- (m,_):_ -> show (Present (mdModuleId m))- in isInfixOf (map toLower str) (map toLower cstr))- $ concatMap flatten (subForest tree)+ $ filter (\ (_,mbPair) ->+ case mbPair of+ Nothing -> False+ Just (mod,_) ->+ let cstr = show (Present (mdModuleId mod))+ in isInfixOf (map toLower str) (map toLower cstr))+ $ concatMap flatten (subForest tree) descrViewSearch :: TreeView -> TreeStore Descr@@ -445,32 +449,29 @@ $ concatMap flatten (subForest tree) fillFacets :: TreeView- -> TreeStore (String, [(ModuleDescr,PackageDescr)])+ -> TreeStore (String, Maybe (ModuleDescr,PackageDescr)) -> TreeView -> TreeStore Descr -> IO () fillFacets treeView treeStore descrView descrStore = do sel <- getSelectionTree treeView treeStore case sel of- Just val- -> case snd val of- ((mod,package):_)- -> let forest = buildFacetForrest mod in do- emptyModel <- treeStoreNew []- treeViewSetModel descrView emptyModel- treeStoreClear descrStore- mapM_ (\(e,i) -> treeStoreInsertTree descrStore [] i e)- $ zip forest [0 .. length forest]- treeViewSetModel descrView descrStore- treeViewSetEnableSearch descrView True- treeViewSetSearchEqualFunc descrView (Just (descrViewSearch descrView descrStore))- [] -> treeStoreClear descrStore- Nothing+ Just (_,Just (mod,package))+ -> let forest = buildFacetForrest mod in do+ emptyModel <- treeStoreNew []+ treeViewSetModel descrView emptyModel+ treeStoreClear descrStore+ mapM_ (\(e,i) -> treeStoreInsertTree descrStore [] i e)+ $ zip forest [0 .. length forest]+ treeViewSetModel descrView descrStore+ treeViewSetEnableSearch descrView True+ treeViewSetSearchEqualFunc descrView (Just (descrViewSearch descrView descrStore))+ otheriwse -> treeStoreClear descrStore getSelectionTree :: TreeView- -> TreeStore (String, [(ModuleDescr,PackageDescr)])- -> IO (Maybe (String, [(ModuleDescr,PackageDescr)]))+ -> TreeStore (String, Maybe (ModuleDescr,PackageDescr))+ -> IO (Maybe (String, Maybe (ModuleDescr,PackageDescr))) getSelectionTree treeView treeStore = do treeSelection <- treeViewGetSelection treeView paths <- treeSelectionGetSelectedRows treeSelection@@ -529,7 +530,7 @@ case accessibleInfo' of Nothing -> liftIO $ do treeStoreClear (treeStore mods)- treeStoreInsertTree (treeStore mods) [] 0 (Node ("",[]) [])+ --treeStoreInsertTree (treeStore mods) [] 0 (Node ("",[]) []) Just (GenScopeC ai@(PackScope pm ps)) -> let p2 = if useBlacklist then PackScope (Map.filter (filterBlacklist@@ -684,7 +685,10 @@ matches _ node (forest,b) = (node:forest,b) -type ModTree = Tree (String, [(ModuleDescr,PackageDescr)])+defaultRoot :: Tree (String, Maybe (ModuleDescr,PackageDescr))+defaultRoot = Node ("",Just (getDefault,getDefault)) []++type ModTree = Tree (String, Maybe (ModuleDescr,PackageDescr)) -- -- | Make a Tree with a module desription, package description pairs tree to display. -- Their are nodes with a label but without a module (like e.g. Data).@@ -693,33 +697,31 @@ buildModulesTree (PackScope localMap _,PackScope otherMap _) = let flatPairs = concatMap (\p -> map (\m -> (m,p)) (pdModules p)) (Map.elems localMap ++ Map.elems otherMap)- emptyTree = (Node ("",[]) [])- resultTree = foldl' insertPairsInTree emptyTree flatPairs+ resultTree = foldl' insertPairsInTree defaultRoot flatPairs in sortTree resultTree where insertPairsInTree :: ModTree -> (ModuleDescr,PackageDescr) -> ModTree insertPairsInTree tree pair = let nameArray = components $ modu $ mdModuleId $ fst pair- pairedWith = map (\n -> (n,pair)) nameArray+ (startArray,last) = splitAt (length nameArray - 1) nameArray+ pairedWith = (map (\n -> (n,Nothing)) startArray) ++ [(head last,Just pair)] in insertNodesInTree pairedWith tree - insertNodesInTree :: [(String,(ModuleDescr,PackageDescr))] -> ModTree -> ModTree- insertNodesInTree list@[(str2,pair)] (Node (str1,pairs) forest) =- case partition (\ (Node (s,_) _) -> s == str2) forest of- ([],_) -> (Node (str1,pairs) (makeNodes list : forest))- ([(Node (_,pairsf) l)],rest)- -> (Node (str1,pairs) ((Node (str2,pair : pairsf) l) : rest))- (_,_) -> throwIDE "insertNodesInTree: impossible1"+ insertNodesInTree :: [(String,Maybe (ModuleDescr,PackageDescr))] -> ModTree -> ModTree+ insertNodesInTree list@[(str2,Just pair)] (Node (str1,pairs) forest) =+ (Node (str1,pairs) (makeNodes list : forest))+ 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))- (_,_) -> throwIDE "insertNodesInTree: impossible2"+ ([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,(ModuleDescr,PackageDescr))] -> ModTree- makeNodes [(str,pair)] = Node (str,[pair]) []- makeNodes ((str,_):tl) = Node (str,[]) [makeNodes tl]+ 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" breakAtDots :: [String] -> String -> [String]@@ -737,7 +739,7 @@ sortTree (Node l forest) = Node l (sort (map sortTree forest)) treeViewPopup :: IDERef- -> TreeStore (String, [(ModuleDescr,PackageDescr)])+ -> TreeStore (String, Maybe (ModuleDescr,PackageDescr)) -> TreeView -> Event -> IO (Bool)@@ -749,7 +751,7 @@ item1 `onActivateLeaf` do sel <- getSelectionTree treeView store case sel of- Just (_,[(m,_)]) -> case mdMbSourcePath m of+ Just (_,Just (m,_)) -> case mdMbSourcePath m of Nothing -> return () Just fp -> do reflectIDE (selectSourceBuf fp) ideR@@ -777,7 +779,7 @@ else if button == LeftButton && click == DoubleClick then do sel <- getSelectionTree treeView store case sel of- Just (_,[(m,_)]) -> case mdMbSourcePath m of+ Just (_,Just (m,_)) -> case mdMbSourcePath m of Nothing -> return () Just fp -> do reflectIDE (selectSourceBuf fp) ideR@@ -884,12 +886,12 @@ liftIO $ treeSelectionUnselectAll ts fillModulesList (sc,bl) let mbs = (case mbTreeSelection of- Nothing -> Nothing- Just (_,[]) -> Nothing- Just (_,((md,_):_)) -> Just (modu $ mdModuleId md),- case mbDescrSelection of- Nothing -> Nothing- Just fw -> Just (dscName fw))+ Just (_,Just (md,_)) -> Just (modu $ mdModuleId md)+ otherwise -> Nothing,+ case mbDescrSelection of+ Nothing -> Nothing+ Just fw -> Just (dscName fw))+ selectNames mbs recordScopeHistory applyExpanderState@@ -933,7 +935,8 @@ (Just (0.3,0.3)) reloadKeepSelection :: Bool -> IDEAction-reloadKeepSelection isInitial = trace (">>>Info Changed!!! " ++ show isInitial) $ do+reloadKeepSelection isInitial = do+ liftIO $ infoM "leksah" (">>>Info Changed!!! " ++ show isInitial) mbMod <- getPane case mbMod of Nothing -> return ()@@ -947,19 +950,18 @@ recordExpanderState fillModulesList sc liftIO $ treeStoreClear (descrStore mods)- let mbs = (case mbTreeSelection of+ let mbs = (case mbTreeSelection of+ Just (_,Just (md,_)) -> Just (modu $ mdModuleId md)+ otherwise -> Nothing,+ case mbDescrSelection of Nothing -> Nothing- Just (_,[]) -> Nothing- Just (_,((md,_):_)) -> Just (modu $ mdModuleId md),- case mbDescrSelection of- Nothing -> Nothing- Just fw -> Just (dscName fw))+ Just fw -> Just (dscName fw))+ applyExpanderState selectNames mbs else if isInitial == True then do- SelectionState moduleS' facetS' sc bl <- trace (">>>Info Changed Initial") $- liftIO $ readIORef (oldSelection mods)+ SelectionState moduleS' facetS' sc bl <- liftIO $ readIORef (oldSelection mods) setScope (sc,bl) fillModulesList (sc, bl) selectNames (moduleS', facetS')@@ -987,7 +989,7 @@ [] -> return () (hd:_) -> treeViewCollapseRow treeView hd >> return () -addModule :: TreeView -> TreeStore (String, [(ModuleDescr,PackageDescr)]) -> IDEAction+addModule :: TreeView -> TreeStore (String, Maybe (ModuleDescr,PackageDescr)) -> IDEAction addModule treeView store = do sel <- liftIO $ treeViewGetSelection treeView paths <- liftIO $ treeSelectionGetSelectedRows sel@@ -1159,9 +1161,8 @@ selTree <- liftIO $ getSelectionTree (treeView mods) (treeStore mods) selDescr <- liftIO $ getSelectionDescr (descrView mods) (descrStore mods) let selMod = case selTree of- Nothing -> Nothing- Just (_,[]) -> Nothing- Just (_,((md,_):_)) -> Just (modu $ mdModuleId md)+ Just (_,Just (md,_)) -> Just (modu $ mdModuleId md)+ otherwise -> Nothing let selFacet = case selDescr of Nothing -> Nothing Just descr -> Just (dscName descr)
src/IDE/Pane/PackageEditor.hs view
@@ -40,7 +40,6 @@ import Distribution.PackageDescription.Configuration (flattenPackageDescription) import Distribution.ModuleName(ModuleName) import Data.Typeable (Typeable(..))-import Debug.Trace (trace) import Graphics.UI.Editor.Composite (versionEditor, versionRangeEditor,@@ -272,7 +271,7 @@ -> (FilePath -> IDEAction) -> IDEM () initPackage packageDir packageD packageDescr panePath nb modules afterSaveAction = do- let fields = trace ("initPackage called " ++ packageDir) $ flattenFieldDescription packageDescr+ let fields = flattenFieldDescription packageDescr let initialPackagePath = packageDir </> (display . pkgName . package . pd) packageD ++ ".cabal" packageInfos <- liftIO $ getInstalledPackageIds buildThisPane panePath nb
src/IDE/Pane/Preferences.hs view
@@ -27,7 +27,11 @@ , getPrefs ) where -import Graphics.UI.Gtk hiding(background)+import Graphics.UI.Gtk+ (cellText, widgetModifyFont, onClicked, boxPackEnd, boxPackStart,+ buttonNewFromStock, hButtonBoxNew, vBoxNew, castToWidget, VBox,+ ShadowType(..), Packing(..), fontDescriptionFromString, AttrOp(..),+ FileChooserAction(..), Color(..)) import Control.Monad.Reader import qualified Text.PrettyPrint.HughesPJ as PP import Distribution.Package@@ -137,7 +141,8 @@ SP.writeStrippedPrefs fp2 (SP.Prefs {SP.sourceDirectories = sourceDirectories newPrefs, SP.unpackDirectory = unpackDirectory newPrefs,- SP.retreiveURL = retreiveURL newPrefs,+ SP.retrieveURL = retrieveURL newPrefs,+ SP.retrieveStrategy = retrieveStrategy newPrefs, SP.serverPort = serverPort newPrefs, SP.endWithLastConn = endWithLastConn newPrefs}) reflectIDE (modifyIDE_ (\ide -> ide{prefs = newPrefs})) ideR )@@ -442,16 +447,23 @@ readParser unpackDirectory (\b a -> a{unpackDirectory = b})- (maybeEditor ((fileEditor (Just (configDir </> "packageSources")) FileChooserActionSelectFolder- "Select folder"), emptyParams) True "Yes")+ (maybeEditor (stringEditor (\ _ -> True),emptyParams) True "") (\i -> return ()) , mkFieldPP- (paraName <<<- ParaName "Maybe an URL to load prebuild metadata " $ emptyParams)+ (paraName <<<- ParaName "An URL to load prebuild metadata" $ emptyParams) (PP.text . show)+ stringParser+ retrieveURL+ (\b a -> a{retrieveURL = b})+ (stringEditor (\ _ -> True))+ (\i -> return ())+ , mkFieldPP+ (paraName <<<- ParaName "A strategy for downloading prebuild metadata" $ emptyParams)+ (PP.text . show) readParser- retreiveURL- (\b a -> a{retreiveURL = b})- (maybeEditor ((stringEditor (\ _ -> True)), emptyParams) True "Yes")+ retrieveStrategy+ (\b a -> a{retrieveStrategy = b})+ (enumEditor ["Retrieve then build","Build then retrieve","Never retrieve"]) (\i -> return ()) , mkFieldPP (paraName <<<- ParaName "Update metadata at startup" $ emptyParams)@@ -599,11 +611,6 @@ maybeEditor (comboSelectionEditor ids id, p) True "Select a special style?" p n -instance Default PackageIdentifier where- getDefault = case packageIdentifierFromString "unknown-0" of- Nothing -> throwIDE "Preferences.getDefault: Can't parse Package Identifier"- Just it -> it- defaultPrefs = Prefs { prefsFormat = prefsVersion , prefsSaveTime = ""@@ -642,7 +649,8 @@ , ("*Search","ToolCategory")] , collectAtStart = True , unpackDirectory = Nothing- , retreiveURL = Just "http://www.leksah.org"+ , retrieveURL = "http://www.leksah.org"+ , retrieveStrategy = SP.RetrieveThenBuild , useCtrlTabFlipping = True , docuSearchURL = "http://holumbus.fh-wedel.de/hayoo/hayoo.html?query=" , completeRestricted = False
src/IDE/Pane/Search.hs view
@@ -22,7 +22,26 @@ , getSearch ) where -import Graphics.UI.Gtk hiding (get)+import Graphics.UI.Gtk+ (listStoreGetValue, treeSelectionGetSelectedRows, widgetShowAll,+ menuPopup, menuShellAppend, onActivateLeaf, menuItemNewWithLabel,+ menuNew, listStoreAppend, listStoreClear, entrySetText,+ afterKeyRelease, onKeyPress, onButtonPress, toggleButtonGetActive,+ widgetSetSensitivity, onToggled, afterFocusIn, vBoxNew, entryNew,+ scrolledWindowSetPolicy, containerAdd, scrolledWindowNew,+ treeSelectionSetMode, treeViewGetSelection,+ treeViewSetHeadersVisible, cellPixbufStockId, cellText,+ cellLayoutSetAttributes, cellLayoutPackStart, treeViewAppendColumn,+ treeViewColumnSetReorderable, treeViewColumnSetResizable,+ treeViewColumnSetSizing, treeViewColumnSetTitle, treeViewColumnNew,+ cellRendererPixbufNew, cellRendererTextNew, treeViewSetModel,+ treeViewNew, listStoreNew, boxPackEnd, boxPackStart,+ checkButtonNewWithLabel, toggleButtonSetActive,+ radioButtonNewWithLabelFromWidget, radioButtonNewWithLabel,+ hBoxNew, entryGetText, castToWidget, Entry, VBox, ListStore,+ TreeView, ScrolledWindow, PolicyType(..), SelectionMode(..),+ TreeViewColumnSizing(..), AttrOp(..),+ Packing(..)) import Graphics.UI.Gtk.Gdk.Events import Data.IORef (newIORef) import Data.IORef (writeIORef,readIORef,IORef(..))
src/IDE/Pane/SourceBuffer.hs view
@@ -84,13 +84,14 @@ import Data.Maybe import Data.Typeable import System.Time++import Graphics.UI.Gtk.Gdk.Events as Gtk import IDE.Core.State import IDE.Utils.GUIUtils(getCandyState) import IDE.Utils.FileUtils import IDE.SourceCandy import IDE.Completion as Completion (complete,cancel) import IDE.TextEditor-import Debug.Trace (trace) import qualified System.IO.UTF8 as UTF8 import Data.IORef (writeIORef,readIORef,newIORef,IORef(..)) import Data.Char (isAlphaNum)@@ -107,13 +108,21 @@ messageDialogNew, postGUIAsync, scrolledWindowSetShadowType, scrolledWindowSetPolicy, castToWidget, ScrolledWindow) import System.Glib.MainLoop (priorityDefaultIdle, idleAdd)+#if MIN_VERSION_gtk(0,10,5)+import Graphics.UI.Gtk (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(..)) import Graphics.UI.Gtk.Windows.MessageDialog (ButtonsType(..), MessageType(..))+#if MIN_VERSION_gtk(0,10,5)+import Graphics.UI.Gtk.Windows.Dialog (ResponseId(..))+#else import Graphics.UI.Gtk.General.Structs (ResponseId(..))+#endif import Graphics.UI.Gtk.Selectors.FileChooser (FileChooserAction(..)) @@ -208,7 +217,6 @@ startComplete :: IDEAction startComplete = do- trace "start complete" return () mbBuf <- maybeActiveBuf currentState' <- readIDE currentState case mbBuf of@@ -454,8 +462,7 @@ iter <- getEndIter buffer -- create a new SourceView Widget- sv <- newView buffer- setFont sv $ textviewFont prefs+ sv <- newView buffer (textviewFont prefs) setShowLineNumbers sv $ showLineNumbers prefs setRightMargin sv $ rightMargin prefs setIndentWidth sv $ tabWidth prefs@@ -1193,21 +1200,18 @@ Just p -> return p Nothing -> case ws of Nothing -> return Nothing- Just workspace -> trace ("bufferToProject unknown " ++ show fp) $ do+ Just workspace -> do mbMn <- liftIO $ moduleNameFromFilePath fp let mbMn2 = case mbMn of Nothing -> Nothing Just mn -> simpleParse mn let res = foldl (belongsToPackage' fp mbMn2) Nothing (wsPackages workspace)- trace ("bufferToProject " ++ case res of- Nothing -> "Nothing"- Just pack -> show (ipdPackageId pack))- $ modifyIDE_ (\ide -> ide{bufferProjCache = Map.insert fp res bufferToProject'})+ modifyIDE_ (\ide -> ide{bufferProjCache = Map.insert fp res bufferToProject'}) return res belongsToPackage' :: FilePath -> Maybe ModuleName -> Maybe IDEPackage -> IDEPackage -> Maybe IDEPackage belongsToPackage' _ _ r@(Just pack) _ = r-belongsToPackage' fp mbModuleName Nothing pack = trace ("belongsToPackage' " ++ show mbModuleName) $+belongsToPackage' fp mbModuleName Nothing pack = let basePath = dropFileName $ ipdCabalFile pack in if isSubPath basePath fp then
src/IDE/Pane/Trace.hs view
@@ -28,7 +28,6 @@ (debugForward, debugBack, debugCommand') import IDE.Utils.Tool (ToolOutput(..)) import IDE.LogRef (srcSpanParser)-import Debug.Trace (trace) import Text.ParserCombinators.Parsec (anyChar, skipMany,@@ -46,6 +45,7 @@ import Text.ParserCombinators.Parsec.Language (emptyDef) import Graphics.UI.Gtk.Gdk.Events (Event(..)) import Graphics.UI.Gtk.General.Enums (MouseButton(..))+import System.Log.Logger (debugM) -- | A debugger pane description@@ -163,8 +163,9 @@ Just tracePane -> debugCommand' ":history" (\to -> liftIO $ postGUIAsync $ do let parseRes = parse tracesParser "" (selectString to) r <- case parseRes of- Left err -> trace ("trace parse error " ++ show err ++ "\ninput: " ++ selectString to)- $ return []+ Left err -> do+ debugM "leksah" ("trace parse error " ++ show err ++ "\ninput: " ++ selectString to)+ return [] Right traces -> return traces treeStoreClear (tracepoints tracePane) let r' = map (\h@(TraceHist _ i _ _) -> if i == currentHist'
src/IDE/Pane/Workspace.hs view
@@ -29,7 +29,6 @@ import IDE.Workspaces import qualified Data.Map as Map (empty) import Data.List (sortBy)-import Debug.Trace (trace) -- | Workspace pane state@@ -182,12 +181,12 @@ treeViewPopup _ _ _ = throwIDE "treeViewPopup wrong event type" updateWorkspace :: Bool -> Bool -> IDEAction-updateWorkspace showPane updateFileCache = trace "updateWorkspace" $ do+updateWorkspace showPane updateFileCache = do mbWs <- readIDE workspace case mbWs of Nothing -> do when updateFileCache $ modifyIDE_ (\ide -> ide{bufferProjCache = Map.empty})- mbMod <- getOrBuildPane (Right ("*Workspace"))+ mbMod <- getPane case mbMod of Nothing -> return () Just (p :: IDEWorkspace) -> do@@ -197,7 +196,7 @@ Just ws -> do when updateFileCache $ modifyIDE_ (\ide -> ide{bufferProjCache = Map.empty, workspace = Just ws{wsReverseDeps = calculateReverseDependencies ws}})- mbMod <- getOrBuildPane (Right ("*Workspace"))+ mbMod <- getPane case mbMod of Nothing -> return () Just (p :: IDEWorkspace) -> do
src/IDE/TextEditor.hs view
@@ -121,6 +121,7 @@ , afterMoveCursor , afterToggleOverwrite , onButtonPress+, onButtonRelease , onCompletion , onKeyPress , onKeyRelease@@ -144,8 +145,8 @@ #ifdef YI import qualified Yi as Yi hiding(withBuffer)-import qualified Yi.Buffer.Misc as Yi import qualified Yi.UI.Pango.Control as Yi+import qualified Yi.Keymap.Cua as Yi import Data.Time (getCurrentTime) import Control.Monad (unless) #endif@@ -188,7 +189,7 @@ #ifdef YI withYiBuffer' :: Yi.BufferRef -> Yi.BufferM a -> IDEM a-withYiBuffer' b f = liftYiControl $ Yi.liftEditor $ Yi.withGivenBuffer0 b f+withYiBuffer' b f = liftYi $ Yi.liftEditor $ Yi.withGivenBuffer0 b f withYiBuffer :: Yi.Buffer -> Yi.BufferM a -> IDEM a withYiBuffer b f = withYiBuffer' (Yi.fBufRef b) f@@ -282,7 +283,7 @@ copyClipboard :: EditorBuffer -> Gtk.Clipboard -> IDEM () copyClipboard (GtkEditorBuffer sb) clipboard = liftIO $ Gtk.textBufferCopyClipboard sb clipboard #ifdef YI-copyClipboard (YiEditorBuffer fb) _ = return () -- TODO+copyClipboard (YiEditorBuffer fb) _ = liftYi $ Yi.liftEditor $ Yi.copy #endif createMark :: EditorBuffer@@ -300,7 +301,7 @@ cutClipboard :: EditorBuffer -> Gtk.Clipboard -> Bool -> IDEM () cutClipboard (GtkEditorBuffer sb) clipboard defaultEditable = liftIO $ Gtk.textBufferCutClipboard sb clipboard defaultEditable #ifdef YI-cutClipboard (YiEditorBuffer fb) clipboard defaultEditable = return () -- TODO+cutClipboard (YiEditorBuffer fb) clipboard defaultEditable = liftYi $ Yi.liftEditor $ Yi.cut #endif delete :: EditorBuffer -> EditorIter -> EditorIter -> IDEM ()@@ -367,7 +368,7 @@ getLineCount :: EditorBuffer -> IDEM Int getLineCount (GtkEditorBuffer sb) = liftIO $ Gtk.textBufferGetLineCount sb #ifdef YI-getLineCount (YiEditorBuffer b) = return 0 -- TODO+getLineCount (YiEditorBuffer b) = withYiBuffer b $ Yi.sizeB >>= Yi.lineOf #endif getModified :: EditorBuffer -> IDEM Bool@@ -453,19 +454,24 @@ moveMark _ _ _ = liftIO $ fail "Mismatching TextEditor types in moveMark" #endif -newView :: EditorBuffer -> IDEM EditorView-newView (GtkEditorBuffer sb) = liftIO $ do- sv <- Gtk.sourceViewNewWithBuffer sb- Gtk.sourceViewSetHighlightCurrentLine sv True- Gtk.sourceViewSetInsertSpacesInsteadOfTabs sv True- Gtk.sourceViewSetIndentOnTab sv True- Gtk.sourceViewSetAutoIndent sv True- Gtk.sourceViewSetSmartHomeEnd sv Gtk.SourceSmartHomeEndBefore- sw <- Gtk.scrolledWindowNew Nothing Nothing- Gtk.containerAdd sw sv- return (GtkEditorView sv)+newView :: EditorBuffer -> Maybe String -> IDEM EditorView+newView (GtkEditorBuffer sb) mbFontString = do+ fd <- fontDescription mbFontString+ liftIO $ do+ sv <- Gtk.sourceViewNewWithBuffer sb+ Gtk.sourceViewSetHighlightCurrentLine sv True+ Gtk.sourceViewSetInsertSpacesInsteadOfTabs sv True+ Gtk.sourceViewSetIndentOnTab sv True+ Gtk.sourceViewSetAutoIndent sv True+ Gtk.sourceViewSetSmartHomeEnd sv Gtk.SourceSmartHomeEndBefore+ sw <- Gtk.scrolledWindowNew Nothing Nothing+ Gtk.containerAdd sw sv+ Gtk.widgetModifyFont sv (Just fd)+ return (GtkEditorView sv) #ifdef YI-newView (YiEditorBuffer b) = liftYiControl $ fmap YiEditorView $ Yi.newView b+newView (YiEditorBuffer b) mbFontString = do+ fd <- fontDescription mbFontString+ liftYiControl $ fmap YiEditorView $ Yi.newView b fd #endif pasteClipboard :: EditorBuffer@@ -476,7 +482,7 @@ pasteClipboard (GtkEditorBuffer sb) clipboard (GtkEditorIter i) defaultEditable = liftIO $ Gtk.textBufferPasteClipboard sb clipboard i defaultEditable #ifdef YI-pasteClipboard (YiEditorBuffer b) clipboard (YiEditorIter (Yi.Iter _ p)) defaultEditable = return () -- TODO+pasteClipboard (YiEditorBuffer b) clipboard (YiEditorIter (Yi.Iter _ p)) defaultEditable = liftYi $ Yi.liftEditor $ Yi.paste pasteClipboard _ _ _ _ = liftIO $ fail "Mismatching TextEditor types in pasteClipboard" #endif @@ -577,7 +583,7 @@ getOverwrite :: EditorView -> IDEM Bool getOverwrite (GtkEditorView sv) = liftIO $ Gtk.textViewGetOverwrite sv #ifdef YI-getOverwrite (YiEditorView v) = return False -- TODO+getOverwrite (YiEditorView Yi.View{Yi.viewFBufRef = b}) = withYiBuffer' b $ not <$> Yi.getA Yi.insertingA #endif getScrolledWindow :: EditorView -> IDEM Gtk.ScrolledWindow@@ -614,26 +620,24 @@ scrollToIter _ _ _ _ = liftIO $ fail "Mismatching TextEditor types in scrollToIter" #endif -setFont :: EditorView -> Maybe String -> IDEM ()-setFont (GtkEditorView sv) mbFontString = liftIO $ do- fd <- case mbFontString of+fontDescription :: Maybe String -> IDEM Gtk.FontDescription+fontDescription mbFontString = liftIO $ do+ case mbFontString of Just str -> do Gtk.fontDescriptionFromString str Nothing -> do f <- Gtk.fontDescriptionNew Gtk.fontDescriptionSetFamily f "Monospace" return f- Gtk.widgetModifyFont sv (Just fd)++setFont :: EditorView -> Maybe String -> IDEM ()+setFont (GtkEditorView sv) mbFontString = do+ fd <- fontDescription mbFontString+ liftIO $ Gtk.widgetModifyFont sv (Just fd) #ifdef YI-setFont (YiEditorView v) mbFontString = liftIO $ do- fd <- case mbFontString of- Just str -> do- Gtk.fontDescriptionFromString str- Nothing -> do- f <- Gtk.fontDescriptionNew- Gtk.fontDescriptionSetFamily f "Monospace"- return f- Gtk.layoutSetFontDescription (Yi.layout v) (Just fd)+setFont (YiEditorView v) mbFontString = do+ fd <- fontDescription mbFontString+ liftIO $ Gtk.layoutSetFontDescription (Yi.layout v) (Just fd) #endif setIndentWidth :: EditorView -> Int -> IDEM ()@@ -940,7 +944,11 @@ ideR <- ask GtkEditorBuffer sb <- getBuffer (GtkEditorView sv) liftIO $ do+#if MIN_VERSION_gtk(0,10,5)+ id1 <- sv `Gtk.after` Gtk.moveCursor $ \_ _ _ -> reflectIDE f ideR+#else id1 <- sv `Gtk.afterMoveCursor` \_ _ _ -> reflectIDE f ideR+#endif sv `Gtk.widgetAddEvents` [Gtk.ButtonReleaseMask] id2 <- sv `Gtk.onButtonRelease` \_ -> reflectIDE f ideR >> return False id3 <- sb `Gtk.afterEndUserAction` reflectIDE f ideR@@ -953,7 +961,11 @@ afterToggleOverwrite (GtkEditorView sv) f = do ideR <- ask liftIO $ do+#if MIN_VERSION_gtk(0,10,5)+ id1 <- sv `Gtk.after` Gtk.toggleOverwrite $ reflectIDE f ideR+#else id1 <- sv `Gtk.afterToggleOverwrite` reflectIDE f ideR+#endif return [ConnectC id1] #ifdef YI afterToggleOverwrite (YiEditorView v) f = return [] -- TODO@@ -975,6 +987,22 @@ return [ConnectC id1] #endif +onButtonRelease :: EditorView+ -> (GtkOld.Event -> IDEM Bool)+ -> IDEM [Connection]+onButtonRelease (GtkEditorView sv) f = do+ ideR <- ask+ liftIO $ do+ id1 <- sv `Gtk.onButtonRelease` \event -> reflectIDE (f event) ideR+ return [ConnectC id1]+#ifdef YI+onButtonRelease (YiEditorView v) f = do+ ideR <- ask+ liftIO $ do+ id1 <- (Yi.drawArea v) `Gtk.onButtonRelease` \event -> reflectIDE (f event) ideR+ return [ConnectC id1]+#endif+ onCompletion :: EditorView -> IDEM () -> IDEM () -> IDEM [Connection] onCompletion (GtkEditorView sv) start cancel = do ideR <- ask@@ -993,7 +1021,11 @@ reflectIDE cancel ideR else reflectIDE cancel ideR+#if MIN_VERSION_gtk(0,10,5)+ id2 <- sv `Gtk.on` Gtk.moveCursor $ \_ _ _ -> reflectIDE cancel ideR+#else id2 <- sv `Gtk.onMoveCursor` \_ _ _ -> reflectIDE cancel ideR+#endif id3 <- sv `Gtk.onButtonPress` \_ -> reflectIDE cancel ideR >> return False return [ConnectC id1] #ifdef YI@@ -1068,7 +1100,11 @@ onPopulatePopup (GtkEditorView sv) f = do ideR <- ask liftIO $ do+#if MIN_VERSION_gtk(0,10,5)+ id1 <- sv `Gtk.on` Gtk.populatePopup $ \menu -> reflectIDE (f menu) ideR+#else id1 <- sv `Gtk.onPopulatePopup` \menu -> reflectIDE (f menu) ideR+#endif return [ConnectC id1] #ifdef YI onPopulatePopup (YiEditorView v) f = do
src/IDE/Utils/GUIUtils.hs view
@@ -36,7 +36,7 @@ ) where import Graphics.UI.Gtk-import System.Process+import IDE.System.Process import Data.Maybe (fromJust, isJust) import Control.Monad import Control.Monad.Trans(MonadIO,liftIO)@@ -46,8 +46,11 @@ --import Graphics.UI.Gtk.General.Structs -- (ResponseId(..)) import qualified Graphics.UI.Gtk.Gdk.Events as G (Event(..))-import Graphics.UI.Gtk.Gdk.Enums(Modifier(..))-+#if MIN_VERSION_gtk(0,10,5)+import Graphics.UI.Gtk.Gdk.EventM (Modifier(..))+#else+import Graphics.UI.Gtk.Gdk.Enums (Modifier(..))+#endif chooseDir :: Window -> String -> Maybe FilePath -> IO (Maybe FilePath) chooseDir window prompt mbFolder = do
src/IDE/Utils/ServerConnection.hs view
@@ -20,7 +20,7 @@ import IDE.Core.State import Network (connectTo,PortID(..)) import Network.Socket (PortNumber(..))-import System.Process(runCommand)+import IDE.System.Process(runProcess) import GHC.Conc(threadDelay) import Control.Monad.Trans(liftIO) import System.IO@@ -30,7 +30,6 @@ import Graphics.UI.Gtk(postGUIAsync) import Control.Event(triggerEvent) - doServerCommand :: ServerCommand -> (ServerAnswer -> IDEM alpha) -> IDEAction doServerCommand command cont = do server' <- readIDE server@@ -70,7 +69,8 @@ startServer :: Int -> IO () startServer port = do- runCommand ("leksah-server --server=" ++ show port ++ " +RTS -N2 -RTS")+ runProcess "leksah-server" ["--server=" ++ show port, "+RTS", "-N2", "-RTS"]+ Nothing Nothing Nothing Nothing Nothing return () -- | s is in tenth's of seconds
src/IDE/Workspaces.hs view
@@ -64,7 +64,11 @@ import System.Time (getClockTime) import Graphics.UI.Gtk.Windows.MessageDialog (ButtonsType(..), MessageType(..))+#if MIN_VERSION_gtk(0,10,5)+import Graphics.UI.Gtk.Windows.Dialog (ResponseId(..))+#else import Graphics.UI.Gtk.General.Structs (ResponseId(..))+#endif import Control.Exception (SomeException(..)) import Control.Monad.Reader.Class (ask) import Data.Map (Map(..))@@ -76,11 +80,10 @@ import IDE.Pane.SourceBuffer (fileOpenThis, belongsToPackage, fileCheckAll) import qualified System.IO.UTF8 as UTF8 (writeFile)-import Debug.Trace (trace) setWorkspace :: Maybe Workspace -> IDEAction-setWorkspace mbWs = trace "setWorkspace" $ do+setWorkspace mbWs = do let mbRealWs = case mbWs of Nothing -> Nothing Just ws -> Just ws{wsReverseDeps = calculateReverseDependencies ws}
+ src/IDE/YiConfig.hs view
@@ -0,0 +1,133 @@+{- Based on example config Yi/Users/Corey.hs that uses the Vim keymap with these additions:+ - Always uses the VTY UI by default.+ - The color style is darkBlueTheme+ - The insert mode of the Vim keymap has been extended with a few additions+ I find useful.+ -}++module IDE.YiConfig (+ yiVimConfig+) where++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.Style.Library (darkBlueTheme)+import Data.List (isPrefixOf, reverse, replicate)+import Control.Monad (replicateM_)++-- Set soft tabs of 4 spaces in width.+prefIndent :: Mode s -> Mode s+prefIndent m = m {+ modeIndentSettings = IndentSettings+ {+ expandTabs = True,+ shiftWidth = 4,+ tabSize = 4+ }}++noHaskellAnnots m+ | modeName m == "haskell" = m { modeGetAnnotations = modeGetAnnotations emptyMode }+ | otherwise = m++yiVimConfig = defaultConfig+ {+ -- Use VTY as the default UI.+ startFrontEnd = Yi.UI.Pango.start,+ defaultKm = mkKeymap extendedVimKeymap,+ modeTable = fmap (onMode $ noHaskellAnnots . prefIndent) (modeTable defaultConfig),+ configUI = (configUI defaultConfig)+ {+ configTheme = defaultLightTheme+ }+ }++extendedVimKeymap = defKeymap `override` \super self -> super+ {+ v_top_level =+ (deprioritize >> v_top_level super)+ -- On 'o' in normal mode I always want to use the indent of the previous line.+ -- TODO: If the line where the newline is to be inserted is inside a+ -- block comment then the block comment should be "continued"+ -- TODO: Ends up I'm trying to replicate vim's "autoindent" feature. This+ -- should be made a function in Yi.+ <|> (char 'o' ?>> beginIns self $ do+ moveToEol+ insertB '\n'+ indentAsPreviousB+ )+ -- On HLX (Haskell Language Extension) I want to go into insert mode such+ -- that the cursor position is correctly placed to start entering the name+ -- of an language extension in a LANGUAGE pragma.+ -- A language pragma will take either the form+ -- {-# LANGUAGE Foo #-}+ -- or+ -- >{-# LANGUAGE Foo #-}+ -- The form should be chosen based on the current mode.+ <|> ( pString "HXL" >> startExtesnionNameInsert self ),+ v_ins_char =+ (deprioritize >> v_ins_char super)+ -- On enter I always want to use the indent of previous line+ -- TODO: If the line where the newline is to be inserted is inside a+ -- block comment then the block comment should be "continued"+ -- TODO: Ends up I'm trying to replicate vim's "autoindent" feature. This+ -- should be made a function in Yi.+ <|> ( spec KEnter ?>>! do+ insertB '\n'+ indentAsPreviousB+ )+ -- I want softtabs to be deleted as if they are tabs. So if the+ -- current col is a multiple of 4 and the previous 4 characters+ -- are spaces then delete all 4 characters.+ -- TODO: Incorporate into Yi itself.+ <|> ( spec KBS ?>>! do+ c <- curCol+ line <- readRegionB =<< regionOfPartB Line Backward+ sw <- indentSettingsB >>= return . shiftWidth+ let indentStr = replicate sw ' '+ toDel = if (c `mod` sw) /= 0+ then 1+ else if indentStr `isPrefixOf` reverse line+ then sw+ else 1+ adjBlock (-toDel)+ replicateM_ toDel $ deleteB Character Backward+ )+ -- On starting to write a block comment I want the close comment+ -- text inserted automatically.+ <|> choice+ [ pString open_tag >>! do+ insertN $ open_tag ++ " \n"+ indentAsPreviousB+ insertN $ " " ++ close_tag+ lineUp+ | (open_tag, close_tag) <-+ [ ("{-", "-}") -- Haskell block comments+ , ("/*", "*/") -- C++ block comments+ ]+ ]+ }+++startExtesnionNameInsert :: ModeMap -> I Event Action ()+startExtesnionNameInsert self = beginIns self $ do+ p_current <- pointB+ m_current <- getMarkB (Just "'")+ setMarkPointB m_current p_current+ moveTo $ Point 0+ insertB '\n'+ moveTo $ Point 0+ insertN "{-# LANGUAGE "+ p <- pointB+ insertN " #-}"+ moveTo p++