diff --git a/data/prefs.lkshp b/data/prefs.lkshp --- a/data/prefs.lkshp +++ b/data/prefs.lkshp @@ -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: diff --git a/data/prefscoll.lkshp b/data/prefscoll.lkshp --- a/data/prefscoll.lkshp +++ b/data/prefscoll.lkshp @@ -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: diff --git a/leksah.cabal b/leksah.cabal --- a/leksah.cabal +++ b/leksah.cabal @@ -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 diff --git a/src/IDE/Command.hs b/src/IDE/Command.hs --- a/src/IDE/Command.hs +++ b/src/IDE/Command.hs @@ -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] diff --git a/src/IDE/Completion.hs b/src/IDE/Completion.hs --- a/src/IDE/Completion.hs +++ b/src/IDE/Completion.hs @@ -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 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 @@ -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 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 @@ -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) diff --git a/src/IDE/Debug.hs b/src/IDE/Debug.hs --- a/src/IDE/Debug.hs +++ b/src/IDE/Debug.hs @@ -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 diff --git a/src/IDE/Find.hs b/src/IDE/Find.hs --- a/src/IDE/Find.hs +++ b/src/IDE/Find.hs @@ -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 diff --git a/src/IDE/ImportTool.hs b/src/IDE/ImportTool.hs --- a/src/IDE/ImportTool.hs +++ b/src/IDE/ImportTool.hs @@ -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 diff --git a/src/IDE/Keymap.hs b/src/IDE/Keymap.hs --- a/src/IDE/Keymap.hs +++ b/src/IDE/Keymap.hs @@ -168,8 +168,11 @@ try $symbol2 "" return Alt <|> do - try $symbol2 "" + try $symbol2 "" return Super + <|> do + try $symbol2 "" + return Meta <|> do try $symbol2 "" return Hyper diff --git a/src/IDE/Leksah.hs b/src/IDE/Leksah.hs --- a/src/IDE/Leksah.hs +++ b/src/IDE/Leksah.hs @@ -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 diff --git a/src/IDE/LogRef.hs b/src/IDE/LogRef.hs --- a/src/IDE/LogRef.hs +++ b/src/IDE/LogRef.hs @@ -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 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 @@ -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 () diff --git a/src/IDE/NotebookFlipper.hs b/src/IDE/NotebookFlipper.hs --- a/src/IDE/NotebookFlipper.hs +++ b/src/IDE/NotebookFlipper.hs @@ -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(..)) 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 @@ -{-# INCLUDE #-} {-# 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 () diff --git a/src/IDE/Package.hs b/src/IDE/Package.hs --- a/src/IDE/Package.hs +++ b/src/IDE/Package.hs @@ -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 diff --git a/src/IDE/Pane/Breakpoints.hs b/src/IDE/Pane/Breakpoints.hs --- a/src/IDE/Pane/Breakpoints.hs +++ b/src/IDE/Pane/Breakpoints.hs @@ -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 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 @@ -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 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 @@ -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) 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 @@ -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 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 @@ -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 diff --git a/src/IDE/Pane/Search.hs b/src/IDE/Pane/Search.hs --- a/src/IDE/Pane/Search.hs +++ b/src/IDE/Pane/Search.hs @@ -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(..)) 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 @@ -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 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 @@ -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' 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 @@ -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 diff --git a/src/IDE/TextEditor.hs b/src/IDE/TextEditor.hs --- a/src/IDE/TextEditor.hs +++ b/src/IDE/TextEditor.hs @@ -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 diff --git a/src/IDE/Utils/GUIUtils.hs b/src/IDE/Utils/GUIUtils.hs --- a/src/IDE/Utils/GUIUtils.hs +++ b/src/IDE/Utils/GUIUtils.hs @@ -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 diff --git a/src/IDE/Utils/ServerConnection.hs b/src/IDE/Utils/ServerConnection.hs --- a/src/IDE/Utils/ServerConnection.hs +++ b/src/IDE/Utils/ServerConnection.hs @@ -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 diff --git a/src/IDE/Workspaces.hs b/src/IDE/Workspaces.hs --- a/src/IDE/Workspaces.hs +++ b/src/IDE/Workspaces.hs @@ -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} diff --git a/src/IDE/YiConfig.hs b/src/IDE/YiConfig.hs new file mode 100644 --- /dev/null +++ b/src/IDE/YiConfig.hs @@ -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 + +