diff --git a/data/Default.candy b/data/Default.candy --- a/data/Default.candy +++ b/data/Default.candy @@ -1,25 +1,25 @@ -- Candy file -"->" 0x2192 Trimming --RIGHTWARDS ARROW -"<-" 0x2190 Trimming --LEFTWARDS ARROW -"=>" 0x21d2 --RIGHTWARDS DOUBLE ARROW -">=" 0x2265 --GREATER-THAN OR EQUAL TO -"<=" 0x2264 --LESS-THAN OR EQUAL TO -"/=" 0x2260 --NOT EQUAL TO -"&&" 0x2227 --LOGICAL AND -"||" 0x2228 --LOGICAL OR -"++" 0x2295 --CIRCLED PLUS ---"::" 0x2551 Trimming --BAR ---"::" 0x2237 Trimming --PROPORTION -".." 0x2025 --TWO DOT LEADER -"^" 0x2191 --UPWARDS ARROW -"==" 0x2261 --IDENTICAL TO ---" . " 0x2218 --RING OPERATOR -"\" 0x03bb --GREEK SMALL LETTER LAMBDA ---"=<<" 0x291e -- -">>=" 0x21a0 -"$" 0x25ca -">>" 0x226b -- MUCH GREATER THEN +"->" 0x2192 Trimming --RIGHTWARDS ARROW -> - +"<-" 0x2190 Trimming --LEFTWARDS ARROW <- - +"=>" 0x21d2 --RIGHTWARDS DOUBLE ARROW => - +">=" 0x2265 --GREATER-THAN OR EQUAL TO >= - +"<=" 0x2264 --LESS-THAN OR EQUAL TO <= - +"/=" 0x2260 --NOT EQUAL TO /= - +"&&" 0x2227 --LOGICAL AND && - +"||" 0x2228 --LOGICAL OR || - +"++" 0x2295 --CIRCLED PLUS ++ - +--"::" 0x2551 Trimming --BAR :: - +--"::" 0x2237 Trimming --PROPORTION :: - +".." 0x2025 --TWO DOT LEADER .. - +"^" 0x2191 --UPWARDS ARROW ^ - +"==" 0x2261 --IDENTICAL TO == - +" . " 0x2218 --RING OPERATOR . - +"\" 0x03bb --GREEK SMALL LETTER LAMBDA \ - +"=<<" 0x291e -- =<< - +">>=" 0x21a0 -- >>= - +"$" 0x25ca -- $ - +">>" 0x226b -- MUCH GREATER THEN >> - "forall" 0x2200 --FOR ALL "exist" 0x2203 --THERE EXISTS diff --git a/doc/leksah_manual.pdf b/doc/leksah_manual.pdf Binary files a/doc/leksah_manual.pdf and b/doc/leksah_manual.pdf differ diff --git a/leksah.cabal b/leksah.cabal --- a/leksah.cabal +++ b/leksah.cabal @@ -1,12 +1,12 @@ name: leksah -version: 0.4.0.2 +version: 0.4.0.3 cabal-version: >=1.4 build-type: Custom license: GPL license-file: LICENSE copyright: 2007-2009 Jürgen Nicklisch-Franken maintainer: Jutaro -build-depends: regex-posix >=0.72.0.3, utf8-string >=0.3.1.1, +build-depends: regex-posix ==0.72.0.3, utf8-string >=0.3.1.1, bytestring >=0.9.0.1, binary >=0.4.4, ghc >=6.10.1, glib >=0.10, gtk >=0.10, directory >=1.0.0.2, pretty >=1.0.1.0, containers >=0.2.0.0, process >=1.0.1.0, mtl >=1.1.0.2, @@ -53,19 +53,20 @@ install-includes: include-dirs: hs-source-dirs: src -other-modules: MyMissing Default DeepSeq Graphics.UI.Editor.Simple - Graphics.UI.Editor.Parameters Graphics.UI.Editor.Basics - Graphics.UI.Editor.Composite Graphics.UI.Editor.MakeEditor - Graphics.UI.Frame.Panes Graphics.UI.Frame.ViewFrame Control.Event - IDE.Package IDE.Keymap IDE.PrinterParser IDE.Exception - IDE.SpecialEditors IDE.SaveSession IDE.Leksah IDE.DescriptionPP - IDE.Find IDE.Menu IDE.FileUtils IDE.SourceCandy IDE.GUIHistory - IDE.Pane.PackageFlags IDE.Pane.Info IDE.Pane.ClassHierarchy - IDE.Pane.SourceBuffer IDE.Pane.Modules IDE.Pane.Preferences - IDE.Pane.Log IDE.Pane.Callers IDE.Pane.Search - IDE.Pane.PackageEditor IDE.Metainfo.Provider - IDE.Metainfo.SourceCollector IDE.Metainfo.InterfaceCollector - IDE.Core.State IDE.Core.Types +other-modules: IDE.Metainfo.GHCUtils MyMissing DeepSeq Default + Control.Event Graphics.UI.Editor.Parameters + Graphics.UI.Editor.Composite Graphics.UI.Editor.Basics + Graphics.UI.Editor.MakeEditor Graphics.UI.Editor.Simple + Graphics.UI.Frame.ViewFrame Graphics.UI.Frame.Panes IDE.Leksah + IDE.PrinterParser IDE.FileUtils IDE.Menu IDE.DescriptionPP IDE.Find + IDE.SourceCandy IDE.Package IDE.SpecialEditors IDE.GUIHistory + IDE.SaveSession IDE.Keymap IDE.Exception IDE.Pane.Modules + IDE.Pane.PackageEditor IDE.Pane.Log IDE.Pane.Search IDE.Pane.Info + IDE.Pane.SourceBuffer IDE.Pane.Preferences IDE.Pane.Callers + IDE.Pane.ClassHierarchy IDE.Pane.PackageFlags + IDE.Metainfo.SourceCollector IDE.Metainfo.Provider + IDE.Metainfo.InterfaceCollector IDE.Core.Types IDE.Core.State + ghc-prof-options: -prof -auto-all ghc-shared-options: -prof -auto-all ghc-options: -fwarn-unused-imports -fwarn-missing-fields -fwarn-incomplete-patterns 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 @@ -214,16 +214,17 @@ -- -- | A reader monad for a mutable reference to the IDE state -- -type IDEM = ReaderT IDERef Ghc +type IDEM = ReaderT IDERef IO -reifyIDE :: (IDERef -> Session -> IO a) -> IDEM a -reifyIDE f = ask >>= \ideR -> lift $ reifyGhc (f ideR) +reifyIDE :: (IDERef -> IO a) -> IDEM a +reifyIDE = ReaderT -reflectIDE :: IDEM a -> IDERef -> Session -> IO a -reflectIDE c ideR = reflectGhc (runReaderT c ideR) +reflectIDE :: IDEM a -> IDERef -> IO a +reflectIDE c ideR = runReaderT c ideR + catchIDE :: Exception e => IDEM a -> (e -> IO a) -> IDEM a -catchIDE block handler = reifyIDE (\ideR session -> catch (reflectIDE block ideR session) handler) +catchIDE block handler = reifyIDE (\ideR -> catch (reflectIDE block ideR) handler) -- -- | A shorthand for a reader monad for a mutable reference to the IDE state @@ -243,8 +244,7 @@ setActivePaneSt v = modifyIDE_ (\ide -> return ide{activePane = v}) setLayoutSt v = modifyIDE_ (\ide -> return ide{layout = v}) - runInIO f = reifyIDE (\ideRef session -> - return (\v -> reflectIDE (f v) ideRef session)) + runInIO f = reifyIDE (\ideRef -> return (\v -> reflectIDE (f v) ideRef)) 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 @@ -124,7 +124,7 @@ , label :: String , tooltip :: Maybe String , stockID :: Maybe String -, action :: ReaderT alpha Ghc () +, action :: ReaderT alpha IO () , accelerator :: [KeyString] , isToggle :: Bool } diff --git a/src/IDE/FileUtils.hs b/src/IDE/FileUtils.hs --- a/src/IDE/FileUtils.hs +++ b/src/IDE/FileUtils.hs @@ -16,8 +16,6 @@ , findSourceFile , autoExtractTarFiles -, getInstalledPackageInfos -, findFittingPackages ) where import System.FilePath @@ -34,21 +32,13 @@ import qualified Data.List as List import qualified Data.Set as Set import Data.Set (Set) -import Data.List (maximumBy,isSuffixOf,isPrefixOf) +import Data.List (isSuffixOf,isPrefixOf) import Distribution.ModuleName(ModuleName,toFilePath) import Distribution.Text(simpleParse) import Debug.Trace import Paths_leksah import IDE.Core.State -import GHC (setSessionDynFlags,getSessionDynFlags,Ghc(..)) -import PackageConfig (PackageConfig(..)) -import DynFlags (DynFlag(..),flags,pkgDatabase) -import UniqFM (eltsUFM) -import Distribution.Simple (PackageIdentifier(..),Dependency(..)) -import qualified Distribution.InstalledPackageInfo as IPI (package) -import Distribution.Version (withinRange) -import Distribution.Package (pkgVersion) import Data.Char (ord) -- | Returns True if the second path is a location which starts with the first path @@ -300,35 +290,7 @@ let libDir2 = if ord (last libDir) == 13 then List.init libDir else libDir - trace ("getSysLibDir " ++ libDir2) $ waitForProcess pid return (normalise libDir2) - --- --------------------------------------------------------------------- --- The (mothers) little helpers --- - -getInstalledPackageInfos :: Ghc [PackageConfig] -getInstalledPackageInfos = do - dflags1 <- getSessionDynFlags - setSessionDynFlags dflags1{flags = Opt_ReadUserPackageConf : (flags dflags1)} - pkgInfos <- case pkgDatabase dflags1 of - Nothing -> return [] - Just fm -> return (eltsUFM fm) - return pkgInfos - -findFittingPackages :: [Dependency] -> Ghc [PackageIdentifier] -findFittingPackages dependencyList = do - knownPackages <- getInstalledPackageInfos - let packages = map IPI.package knownPackages - return (concatMap (fittingKnown packages) dependencyList) - where - fittingKnown packages (Dependency dname versionRange) = - let filtered = filter (\ (PackageIdentifier name version) -> - name == dname && withinRange version versionRange) - packages - in if length filtered > 1 - then [maximumBy (\a b -> compare (pkgVersion a) (pkgVersion b)) filtered] - else filtered diff --git a/src/IDE/Find.hs b/src/IDE/Find.hs --- a/src/IDE/Find.hs +++ b/src/IDE/Find.hs @@ -148,7 +148,7 @@ else showFindbar constructFindReplace :: Toolbar -> IDEM (Toolbar) -constructFindReplace toolbar = reifyIDE $ \ ideR session -> do +constructFindReplace toolbar = reifyIDE $ \ ideR -> do closeButton <- toolButtonNewFromStock "gtk-close" toolbarInsert toolbar closeButton 0 @@ -228,35 +228,35 @@ containerAdd labelTool label toolbarInsert toolbar labelTool 0 - findButton `onToolButtonClicked` (doSearch toolbar Forward ideR session) + findButton `onToolButtonClicked` (doSearch toolbar Forward ideR ) entry `afterInsertText` (\t i -> do - doSearch toolbar Insert ideR session + doSearch toolbar Insert ideR return i) - entry `afterDeleteText` (\ _ _ -> doSearch toolbar Delete ideR session) + entry `afterDeleteText` (\ _ _ -> doSearch toolbar Delete ideR ) entry `afterKeyPress` (\ e -> case e of k@(Key _ _ _ _ _ _ _ _ _ _) | eventKeyName k == "Down" -> do - doSearch toolbar Forward ideR session + doSearch toolbar Forward ideR return True | eventKeyName k == "Up" -> do - doSearch toolbar Backward ideR session + doSearch toolbar Backward ideR return True | eventKeyName k == "Escape" -> do - getOut ideR session + getOut ideR return True | otherwise -> return True _ -> return True) - entry `onEntryActivate` getOut ideR session - replaceButton `onToolButtonClicked` replace toolbar Forward ideR session + entry `onEntryActivate` getOut ideR + replaceButton `onToolButtonClicked` replace toolbar Forward ideR - replaceAllButton `onToolButtonClicked` replaceAll toolbar Forward ideR session + replaceAllButton `onToolButtonClicked` replaceAll toolbar Forward ideR spinL `afterFocusIn` (\ _ -> (reflectIDE (inBufContext True $ \_ gtkbuf currentBuffer _ -> do max <- textBufferGetLineCount gtkbuf spinButtonSetRange spinL 1.0 (fromIntegral max) - return True) ideR session)) + return True) ideR )) spinL `afterEntryActivate` (reflectIDE (inBufContext () $ \_ gtkbuf currentBuffer _ -> do @@ -265,10 +265,10 @@ textIterSetLine iter (line - 1) textBufferPlaceCursor gtkbuf iter textViewScrollToIter (sourceView currentBuffer) iter 0.2 Nothing - return ()) ideR session) + return ()) ideR ) closeButton `onToolButtonClicked` do - reflectIDE hideFindbar ideR session + reflectIDE hideFindbar ideR set toolbar [ toolbarChildHomogeneous spinTool := False ] set toolbar [ toolbarChildHomogeneous wrapAroundButton := False ] @@ -291,14 +291,14 @@ return () -doSearch :: Toolbar -> SearchHint -> IDERef -> Session -> IO () -doSearch fb hint ideR session = do +doSearch :: Toolbar -> SearchHint -> IDERef -> IO () +doSearch fb hint ideR = do entry <- getFindEntry fb search <- entryGetText (castToEntry entry) entireWord <- getEntireWord fb caseSensitive <- getCaseSensitive fb wrapAround <- getWrapAround fb - res <- reflectIDE (editFind entireWord caseSensitive wrapAround search "" hint) ideR session + res <- reflectIDE (editFind entireWord caseSensitive wrapAround search "" hint) ideR if res || null search then do widgetModifyBase entry StateNormal white @@ -308,8 +308,8 @@ widgetModifyText entry StateNormal white return () -replace :: Toolbar -> SearchHint -> IDERef -> Session -> IO () -replace fb hint ideR session = do +replace :: Toolbar -> SearchHint -> IDERef -> IO () +replace fb hint ideR = do entry <- getFindEntry fb search <- entryGetText (castToEntry entry) rentry <- getReplaceEntry fb @@ -318,12 +318,12 @@ caseSensitive <- getCaseSensitive fb wrapAround <- getWrapAround fb found <- reflectIDE (editReplace entireWord caseSensitive wrapAround search replace hint) - ideR session + ideR return () -replaceAll :: Toolbar -> SearchHint -> IDERef -> Session -> IO () -replaceAll fb hint ideR session = do +replaceAll :: Toolbar -> SearchHint -> IDERef -> IO () +replaceAll fb hint ideR = do entry <- getFindEntry fb search <- entryGetText (castToEntry entry) rentry <- getReplaceEntry fb @@ -332,7 +332,7 @@ caseSensitive <- getCaseSensitive fb wrapAround <- getWrapAround fb found <- reflectIDE (editReplaceAll entireWord caseSensitive wrapAround search replace hint) - ideR session + ideR return () editFind :: Bool -> Bool -> Bool -> String -> String -> SearchHint -> IDEM Bool @@ -443,12 +443,12 @@ editFindInc hint = do showFindbar fb <- readIDE findbar - reifyIDE $ \ideR session -> do + reifyIDE $ \ideR -> do entry <- getFindEntry fb widgetGrabFocus entry case hint of - Forward -> doSearch fb Forward ideR session - Backward -> doSearch fb Backward ideR session + Forward -> doSearch fb Forward ideR + Backward -> doSearch fb Backward ideR _ -> return () editGotoLine :: IDEAction diff --git a/src/IDE/Leksah.hs b/src/IDE/Leksah.hs --- a/src/IDE/Leksah.hs +++ b/src/IDE/Leksah.hs @@ -31,7 +31,6 @@ import System.Console.GetOpt import System.Environment import GHC -import HscTypes hiding (liftIO) import Config import Data.Version import Prelude hiding(catch) @@ -63,6 +62,8 @@ import IDE.Find import Graphics.UI.Editor.Composite (maybeEditor) import Graphics.UI.Editor.Simple (fileEditor) +--import Outputable (ppr,showSDoc) +import IDE.Metainfo.GHCUtils (inGhcIO) -- --------------------------------------------------------------------- -- Command line options @@ -121,9 +122,8 @@ buildSourceForPackageDB sysMessage Normal "rebuild SourceForPackageDB") when (elem Rebuild o || elem Collect o || not (null uninstalled)) $ do - libDir <- getSysLibDir - runGhc (Just libDir) $ do - getSessionDynFlags >>= setSessionDynFlags + inGhcIO $ do + flags <- getSessionDynFlags let version = cProjectVersion let uninstalled = filter (\x -> case x of UninstalledProject _ -> True @@ -145,7 +145,7 @@ st <- initGUI when rtsSupportsBoundThreads (sysMessage Normal "Linked with -threaded") - timeoutAddFull (yield >> return True) priorityHigh 25 + timeoutAddFull (yield >> return True) priorityHigh 5 mapM_ (sysMessage Normal) st uiManager <- uiManagerNew newIcons @@ -194,65 +194,69 @@ , toolbar = Nothing , findbarVisible = True , toolbarVisible = True -} + } ideR <- newIORef ide - libDir <- getSysLibDir - runGhc (Just libDir) (do - getSessionDynFlags >>= setSessionDynFlags - reifyGhc (\session -> do - menuDescription' <- menuDescription - (acc,menus) <- reflectIDE (makeMenu uiManager accelActions menuDescription') ideR session - when (length menus /= 2) $ throwIDE ("Failed to build menu" ++ show (length menus)) - let toolbar = castToToolbar (menus !! 1) - reflectIDE (do - constructFindReplace findBar - modifyIDE_ (\ide -> return ide{toolbar = Just toolbar}) - initInfo :: IDEAction) ideR session - sep0 <- separatorToolItemNew - separatorToolItemSetDraw sep0 False - toolItemSetExpand sep0 True - toolbarInsert toolbar sep0 (-1) - closeButton <- toolButtonNewFromStock "gtk-close" - toolbarInsert toolbar closeButton (-1) - closeButton `onToolButtonClicked` do - reflectIDE hideToolbar ideR session + menuDescription' <- menuDescription + (acc,menus) <- reflectIDE (makeMenu uiManager accelActions menuDescription') ideR + when (length menus /= 2) $ throwIDE ("Failed to build menu" ++ show (length menus)) + let toolbar = castToToolbar (menus !! 1) + reflectIDE (do + constructFindReplace findBar + modifyIDE_ (\ide -> return ide{toolbar = Just toolbar}) + initInfo :: IDEAction) ideR + sep0 <- separatorToolItemNew + separatorToolItemSetDraw sep0 False + toolItemSetExpand sep0 True + toolbarInsert toolbar sep0 (-1) + closeButton <- toolButtonNewFromStock "gtk-close" + toolbarInsert toolbar closeButton (-1) + closeButton `onToolButtonClicked` do + reflectIDE hideToolbar ideR - windowAddAccelGroup win acc - nb <- newNotebook - afterSwitchPage nb (\i -> reflectIDE (handleNotebookSwitch nb i) ideR session) - widgetSetName nb $"root" - statusBar <- buildStatusbar ideR - vb <- vBoxNew False 1 -- Top-level vbox - widgetSetName vb "topBox" - toolbarSetStyle (castToToolbar (menus !! 1)) ToolbarIcons - boxPackStart vb (menus !! 0) PackNatural 0 - boxPackStart vb (menus !! 1) PackNatural 0 - boxPackStart vb nb PackGrow 0 - boxPackStart vb findBar PackNatural 0 - boxPackEnd vb statusBar PackNatural 0 - win `onDelete` (\ _ -> do reflectIDE quit ideR session; return True) - win `onKeyPress` (\ e -> reflectIDE (handleSpecialKeystrokes e) ideR session) - containerAdd win vb - reflectIDE (setCandyState (isJust (sourceCandy prefs))) ideR session - let (x,y) = defaultSize prefs - windowSetDefaultSize win x y - sessionPath <- getConfigFilePathForLoad sessionFilename - (tbv,fbv) <- reflectIDE (do - registerEvents menus - recoverSession sessionPath - ) ideR session - widgetShowAll win - reflectIDE (do - if tbv - then showToolbar - else hideToolbar - if fbv - then showFindbar - else hideFindbar) ideR session - mainGUI)) + windowAddAccelGroup win acc + nb <- newNotebook + afterSwitchPage nb (\i -> reflectIDE (handleNotebookSwitch nb i) ideR) + widgetSetName nb $"root" + statusBar <- buildStatusbar ideR + vb <- vBoxNew False 1 -- Top-level vbox + widgetSetName vb "topBox" + toolbarSetStyle (castToToolbar (menus !! 1)) ToolbarIcons + boxPackStart vb (menus !! 0) PackNatural 0 + boxPackStart vb (menus !! 1) PackNatural 0 + boxPackStart vb nb PackGrow 0 + boxPackStart vb findBar PackNatural 0 + boxPackEnd vb statusBar PackNatural 0 + win `onDelete` (\ _ -> do reflectIDE quit ideR; return True) + win `onKeyPress` (\ e -> reflectIDE (handleSpecialKeystrokes e) ideR) + containerAdd win vb + reflectIDE (setCandyState (isJust (sourceCandy prefs))) ideR + let (x,y) = defaultSize prefs + windowSetDefaultSize win x y + sessionPath <- getConfigFilePathForLoad sessionFilename + (tbv,fbv) <- reflectIDE (do + registerEvents menus + recoverSession sessionPath + ) ideR + reflectIDE (do + if tbv + then showToolbar + else hideToolbar + if fbv + then showFindbar + else hideFindbar) ideR + widgetShowAll win +-- patch for windows + buffers <- reflectIDE allBuffers ideR + fdesc <- fontDescriptionFromString (case textviewFont prefs of Just str -> str; Nothing -> "") + fds <- fontDescriptionGetSize fdesc + when (isJust fds) $ do + fontDescriptionSetSize fdesc (fromJust fds + 0.01) + mapM_ (\buf -> widgetModifyFont (castToWidget $sourceView buf) (Just fdesc)) buffers +-- end patch + mainGUI -- --- | Callback function for onKeyPress of the main window, so preprocess any key +-- | Callback function for onKeyPress of the main window, so 'preprocess' any key -- handleSpecialKeystrokes :: GdkEvents.Event -> IDEM Bool handleSpecialKeystrokes (Key _ _ _ mods _ _ _ keyVal name mbChar) = do diff --git a/src/IDE/Menu.hs b/src/IDE/Menu.hs --- a/src/IDE/Menu.hs +++ b/src/IDE/Menu.hs @@ -255,9 +255,9 @@ -- | Building the Menu -- makeMenu :: UIManager -> [ActionDescr IDERef] -> String -> IDEM (AccelGroup, [Widget]) -makeMenu uiManager actions menuDescription = reifyIDE (\ideR session -> do +makeMenu uiManager actions menuDescription = reifyIDE (\ideR -> do actionGroupGlobal <- actionGroupNew "global" - mapM_ (actm ideR session actionGroupGlobal) actions + mapM_ (actm ideR actionGroupGlobal) actions uiManagerInsertActionGroup uiManager actionGroupGlobal 1 uiManagerAddUiFromString uiManager menuDescription accGroup <- uiManagerGetAccelGroup uiManager @@ -267,26 +267,26 @@ Nothing -> throwIDE "Menu>>makeMenu: failed to build menu") mbWidgets return (accGroup,widgets)) where - actm ideR session ag (AD name label tooltip stockId ideAction accs isToggle) = do + actm ideR ag (AD name label tooltip stockId ideAction accs isToggle) = do let (acc,accString) = if null accs then (Just "","=" ++ name) else (Just (head accs),(head accs) ++ "=" ++ name) if isToggle then do act <- toggleActionNew name label tooltip stockId - on act actionToggled (doAction ideAction ideR session accString) + on act actionToggled (doAction ideAction ideR accString) actionGroupAddActionWithAccel ag act acc else do act <- actionNew name label tooltip stockId - onActionActivate act (doAction ideAction ideR session accString) + onActionActivate act (doAction ideAction ideR accString) actionGroupAddActionWithAccel ag act acc - doAction ideAction ideR session accStr = + doAction ideAction ideR accStr = handleTopExceptions (reflectIDE (do ideAction sb <- getSBSpecialKeys liftIO $statusbarPop sb 1 liftIO $statusbarPush sb 1 $accStr - return ()) ideR session) + return ()) ideR) -- | Quit ide -- ### make reasonable diff --git a/src/IDE/Metainfo/GHCUtils.hs b/src/IDE/Metainfo/GHCUtils.hs new file mode 100644 --- /dev/null +++ b/src/IDE/Metainfo/GHCUtils.hs @@ -0,0 +1,66 @@ +----------------------------------------------------------------------------- +-- +-- Module : IDE.Metainfo.GHCUtils +-- Copyright : 2007-2009 Jürgen Nicklisch-Franken +-- License : GPL +-- +-- Maintainer : Jutaro +-- Stability : provisional +-- Portability : +-- +-- | +-- +----------------------------------------------------------------------------- module IDE.Metainfo.GHCUtils ( + + inGhc +, inGhcIO +, getInstalledPackageInfos +, findFittingPackages + +) where + +import GHC (setSessionDynFlags,getSessionDynFlags,runGhc,Ghc(..)) +import IDE.Core.State (IDEM(..)) +import IDE.FileUtils (getSysLibDir) +import Control.Monad.Trans (liftIO) +import PackageConfig (PackageConfig(..)) +import DynFlags (pkgDatabase,DynFlag(..),flags) +import UniqFM (eltsUFM) +import Distribution.Simple (withinRange,PackageIdentifier(..),Dependency(..)) +import qualified Distribution.InstalledPackageInfo as IPI (package) +import Data.List (maximumBy) +import Distribution.Package (pkgVersion) + +inGhc :: Ghc a -> IDEM a +inGhc = liftIO . inGhcIO + +inGhcIO :: Ghc a -> IO a +inGhcIO f = do + libDir <- getSysLibDir + runGhc (Just libDir) $ do + getSessionDynFlags >>= setSessionDynFlags + f + +getInstalledPackageInfos :: Ghc [PackageConfig] +getInstalledPackageInfos = do + dflags1 <- getSessionDynFlags + setSessionDynFlags dflags1{flags = Opt_ReadUserPackageConf : (flags dflags1)} + pkgInfos <- case pkgDatabase dflags1 of + Nothing -> return [] + Just fm -> return (eltsUFM fm) + return pkgInfos + +findFittingPackages :: [Dependency] -> Ghc [PackageIdentifier] +findFittingPackages dependencyList = do + knownPackages <- getInstalledPackageInfos + let packages = map IPI.package knownPackages + return (concatMap (fittingKnown packages) dependencyList) + where + fittingKnown packages (Dependency dname versionRange) = + let filtered = filter (\ (PackageIdentifier name version) -> + name == dname && withinRange version versionRange) + packages + in if length filtered > 1 + then [maximumBy (\a b -> compare (pkgVersion a) (pkgVersion b)) filtered] + else filtered + diff --git a/src/IDE/Metainfo/InterfaceCollector.hs b/src/IDE/Metainfo/InterfaceCollector.hs --- a/src/IDE/Metainfo/InterfaceCollector.hs +++ b/src/IDE/Metainfo/InterfaceCollector.hs @@ -15,11 +15,8 @@ module IDE.Metainfo.InterfaceCollector ( collectInstalled -, collectInstalledI , collectInstalled' , collectUninstalled -, getInstalledPackageInfos -, findFittingPackages , metadataVersion ) where @@ -27,6 +24,7 @@ import GHC hiding(Id,Failed,Succeeded,ModuleName) import Module hiding (PackageId,ModuleName) +import IDE.Metainfo.GHCUtils (findFittingPackages,getInstalledPackageInfos) import qualified Module import TcRnMonad hiding (liftIO,MonadIO) import qualified Maybes as M @@ -80,6 +78,7 @@ import IDE.FileUtils --import IDE.Metainfo.Provider import IDE.Metainfo.SourceCollector +import IDE.Metainfo.GHCUtils(inGhc) metadataVersion :: Integer metadataVersion = 3 @@ -96,15 +95,8 @@ getDefault = CollectStatistics getDefault getDefault getDefault getDefault getDefault -collectInstalledI :: Bool -> IDEAction -collectInstalledI b = do - session' <- lift $ getSession - lift $ collectInstalled' False cProjectVersion b - - -collectInstalled :: HscEnv -> Bool -> Ghc () -collectInstalled session b = do - collectInstalled' False cProjectVersion b +collectInstalled :: Bool -> IDEAction +collectInstalled b = inGhc $ collectInstalled' False cProjectVersion b collectInstalled' :: Bool -> String -> Bool -> Ghc() collectInstalled' writeAscii version forceRebuild = do @@ -159,13 +151,14 @@ collectUninstalled :: Bool -> String -> FilePath -> Ghc () collectUninstalled writeAscii version cabalPath = do - pd <- liftIO $ readPackageDescription normal cabalPath + trace ("collect Uninstalled " ++ show cabalPath) return () + cCabalPath <- liftIO $ canonicalizePath cabalPath + pd <- liftIO $ readPackageDescription normal cCabalPath >>= return . flattenPackageDescription let packageName = if hasExes pd then "main" else show $ package pd let modules = nub $ exeModules pd ++ libModules pd - cCabalPath <- liftIO $ canonicalizePath cabalPath let basePath = takeDirectory cCabalPath let buildPath = if hasExes pd then let exeName' = exeName (head (executables pd)) @@ -187,11 +180,11 @@ allIfaceInfos <- getIFaceInfos2 ghcmodules packageName deps <- findFittingPackages (buildDepends pd) let extracted = extractInfo (allIfaceInfos, [], package pd, deps) - let sources = Map.fromList [(package pd,[cabalPath])] + let sources = Map.fromList [(package pd,[cCabalPath])] (extractedWithSources,_) <- collectSources sources extracted collectorPath <- getCollectorPath version writeExtracted collectorPath writeAscii True extractedWithSources - sysMessage Normal $ "\nExtracted infos for " ++ cabalPath ++ + sysMessage Normal $ "\nExtracted infos for " ++ cCabalPath ++ " size: " ++ (show . length) (exposedModulesPD extractedWithSources) ------------------------------------------------------------------------- @@ -372,7 +365,7 @@ (map extractType (ifConArgTys decl)) extractType :: IfaceType -> TypeInfo -extractType decl = BS.pack $ filterExtras $ showSDocUnqual $ppr decl +extractType = BS.pack . filterExtras . showSDocUnqual . ppr extractFieldNames :: OccName -> Symbol extractFieldNames occName = unpackFS $occNameFS occName 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 @@ -48,7 +48,7 @@ import Control.Monad.Reader(ask) import Distribution.Version import Distribution.ModuleName -import GHC (runGhc,getSession) +import GHC (runGhc) import DeepSeq import IDE.FileUtils @@ -59,6 +59,7 @@ import Text.Regex.Posix import System.IO.Unsafe (unsafePerformIO) import Text.Regex.Posix.String (execute,compile) +import IDE.Metainfo.GHCUtils (findFittingPackages,getInstalledPackageInfos,inGhc) -- -- | Searching of metadata @@ -149,10 +150,9 @@ initInfo :: IDEAction initInfo = do prefs <- readIDE prefs - session' <- lift getSession when (collectAtStart prefs) $ do ideMessage Normal "Now updating metadata ..." - lift $ collectInstalled session' False + collectInstalled False ideMessage Normal "Now loading metadata ..." loadAccessibleInfo ideMessage Normal "Finished loading ..." @@ -165,7 +165,7 @@ loadAccessibleInfo = let version = cProjectVersion in do collectorPath <- lift $ getCollectorPath version - packageInfos <- lift $ getInstalledPackageInfos + packageInfos <- inGhc $ getInstalledPackageInfos packageList <- liftIO $ mapM (loadInfosForPackage collectorPath False) (map DP.package packageInfos) let scope = foldr buildScope (Map.empty,Map.empty) @@ -194,7 +194,7 @@ modifyIDE_ (\ide -> return (ide{currentInfo = Nothing})) Just pack -> do let depends' = depends pack - fp <- lift $findFittingPackages depends' + fp <- inGhc $ findFittingPackages depends' mbActive <- loadOrBuildActiveInfo case mbActive of Nothing -> do @@ -221,7 +221,7 @@ -- If a process handle is given, it waits for this process to finish before building -- mayRebuildInBackground :: Maybe ProcessHandle -> IDEAction -mayRebuildInBackground mbHandle = reifyIDE $ \ ideR session -> +mayRebuildInBackground mbHandle = reifyIDE $ \ ideR -> let myRebuild :: IO Bool myRebuild = @@ -239,12 +239,13 @@ errs <- readIDE errors when (length (filter isError errs) == 0) $ do ideMessage Normal "Update meta info for active package" - setInfo buildActiveInfo) ideR session + setInfo buildActiveInfo) ideR return False in do timeoutAddFull myRebuild priorityDefaultIdle 500 return () +rebuildActiveInfo :: IDEAction rebuildActiveInfo = setInfo buildActiveInfo -- @@ -306,7 +307,7 @@ Just idePackage -> do libDir <- liftIO $ getSysLibDir liftIO $ runGhc (Just libDir) - $ collectUninstalled False cProjectVersion (cabalFile idePackage) + $ collectUninstalled False cProjectVersion (takeFileName $ cabalFile idePackage) -- ideMessage Normal "uninstalled collected" collectorPath <- lift $ getCollectorPath cProjectVersion packageDescr <- liftIO $ loadInfosForPackage collectorPath True @@ -333,7 +334,7 @@ case wi of Nothing -> loadAccessibleInfo Just (psmap,psst) -> do - packageInfos <- lift getInstalledPackageInfos + packageInfos <- inGhc getInstalledPackageInfos let packageIds = map DP.package packageInfos let newPackages = filter (\ pi -> Map.member pi psmap) packageIds let trashPackages = filter (\ e -> not (elem e packageIds))(Map.keys psmap) diff --git a/src/IDE/Metainfo/SourceCollector.hs b/src/IDE/Metainfo/SourceCollector.hs --- a/src/IDE/Metainfo/SourceCollector.hs +++ b/src/IDE/Metainfo/SourceCollector.hs @@ -19,6 +19,8 @@ , sourceForPackage , parseSourceForPackageDB , getSourcesMap + +, unloadGhc ) where import qualified Text.PrettyPrint.HughesPJ as PP @@ -66,25 +68,33 @@ -> PackageDescr -> Ghc (PackageDescr,Int) collectSources sourceMap pdescr = do + unloadGhc sysMessage Normal $ "Now collecting sources for " ++ display (packagePD pdescr) case sourceForPackage (packagePD pdescr) sourceMap of Nothing -> do sysMessage Normal $ "No source for package " ++ display (packagePD pdescr) return (pdescr,0) - Just cabalPath -> gcatch (do - basePath <- liftIO $ canonicalizePath (takeDirectory cabalPath) + Just cabalPath' -> gcatch (do + cabalPath <- liftIO $ canonicalizePath cabalPath' + let basePath = takeDirectory cabalPath pkgDescr <- gcatch (liftIO $ (liftM flattenPackageDescription (readPackageDescription silent cabalPath))) (\(e :: SomeException) -> return emptyPackageDescription) - let bis = allBuildInfo pkgDescr - let buildPaths = map (\p -> basePath p) - $ nub $ ("dist" "build" "autogen") : (".") - : concatMap hsSourceDirs bis - let includes = map (\p -> basePath p) $ nub $ concatMap includeDirs bis - + let bis = allBuildInfo pkgDescr + let buildPaths = if hasExes pkgDescr + then let exeName' = exeName (head (executables pkgDescr)) + in -- map (\p -> basePath p) $ + ("dist" "build" exeName' + exeName' ++ "-tmp" "") : + ("dist" "build" "autogen") : (".") + : (nub $ concatMap hsSourceDirs bis) + else -- map (\p -> basePath p) $ + ("dist" "build" "autogen") : (".") + : (nub $ concatMap hsSourceDirs bis) + let includes = {-- map (\p -> basePath p) $ --} nub $ concatMap includeDirs bis dflags <- getSessionDynFlags let dflags2 = dflags { - topDir = basePath, + topDir = basePath, hscTarget = HscAsm, ghcMode = CompManager, ghcLink = NoLink} @@ -132,7 +142,9 @@ collectSourcesForPackage pkgDescr sourceFiles interesting = do targets <- mapM (\f -> guessTarget f Nothing) sourceFiles setTargets targets + trace ("before depanal") $ return () modgraph <- depanal [] False + trace ("after depanal") $ return () let orderedMods = flattenSCCs $ topSortModuleGraph False modgraph Nothing let interestingMods = filter (\m -> elem (moduleNameString (ms_mod_name m)) interesting) orderedMods let orderedTupels = catMaybes (map (\om -> case filter (\m -> ((moduleNameString . moduleName . ms_mod) om) == @@ -144,8 +156,8 @@ collectSourcesForModule :: ([ModuleDescr],Int) -> (ModuleDescr, ModSummary) -> Ghc ([ModuleDescr],Int) collectSourcesForModule (moduleDescrs,failureCount) (modD,modsum) = gcatch (do - let filename = msHsFilePath modsum - let dynflags = ms_hspp_opts modsum + let filename = msHsFilePath modsum + let dynflags = ms_hspp_opts modsum parsedMod <- parseModule modsum let decls = (hsmodDecls . unLoc . parsedSource) $ parsedMod let map' = convertToMap (idDescriptionsMD modD) @@ -320,6 +332,12 @@ show (DocCommentPrev doc) = "DocCommentPrev " ++ show doc show (DocCommentNamed str doc) = "DocCommentNamed" ++ " " ++ str ++ " " ++ show doc show (DocGroup i doc) = "DocGroup" ++ " " ++ show i ++ " " ++ show doc + +unloadGhc :: Ghc () +unloadGhc = do + setTargets [] + load LoadAllTargets + return () -- --------------------------------------------------------------------- -- Function to map packages to file paths diff --git a/src/IDE/Package.hs b/src/IDE/Package.hs --- a/src/IDE/Package.hs +++ b/src/IDE/Package.hs @@ -123,11 +123,11 @@ ideR <- ask let ppath = dropFileName filePath liftIO $ setCurrentDirectory ppath - mbPackageD <- reifyIDE (\ideR session -> catch (do + mbPackageD <- reifyIDE (\ideR -> catch (do pd <- readPackageDescription normal filePath return (Just (flattenPackageDescription pd))) (\(e :: SomeException) -> do - reflectIDE (ideMessage Normal ("Can't activate package " ++(show e))) ideR session + reflectIDE (ideMessage Normal ("Can't activate package " ++(show e))) ideR return Nothing)) case mbPackageD of Nothing -> return (Nothing) @@ -173,7 +173,7 @@ case mbPackage of Nothing -> return () Just package -> do - mbPackageD <- reifyIDE (\ideR session -> catch (do + mbPackageD <- reifyIDE (\ideR -> catch (do (inp,out,err,pid) <- runExternal "runhaskell" (["Setup","configure"] ++ (configFlags package)) oid <- forkIO(readOut log out) @@ -181,7 +181,7 @@ pd <- readPackageDescription normal (cabalFile package) return (Just (flattenPackageDescription pd))) (\(e :: SomeException) -> do - reflectIDE (ideMessage Normal (show e)) ideR session + reflectIDE (ideMessage Normal (show e)) ideR return Nothing)) case mbPackageD of Just packageD -> do @@ -205,12 +205,12 @@ liftIO $statusbarPop sb 1 liftIO $statusbarPush sb 1 "Building" unmarkCurrentError - pid' <- reifyIDE (\ideR session -> do + pid' <- reifyIDE (\ideR -> do (inp,out,err,pid) <- runExternal "runhaskell" (["Setup","build"] ++ buildFlags package) oid <- forkIO (readOut log out) hSetBuffering err NoBuffering - eid <- forkIO (reflectIDE (readErrForBuild log err) ideR session) + eid <- forkIO (reflectIDE (readErrForBuild log err) ideR) return pid) when (collectAfterBuild prefs) $ mayRebuildInBackground (Just pid')) (\(e :: SomeException) -> putStrLn (show e)) @@ -576,11 +576,11 @@ return Nothing Just p -> do ideR <- ask - reifyIDE (\ideR session -> catch (do + reifyIDE (\ideR -> catch (do pd <- readPackageDescription normal (cabalFile p) return (Just (flattenPackageDescription pd,cabalFile p))) (\(e :: SomeException) -> do - reflectIDE (ideMessage Normal ("Can't load package " ++(show e))) ideR session + reflectIDE (ideMessage Normal ("Can't load package " ++(show e))) ideR return Nothing)) getModuleTemplate :: PackageDescription -> String -> IO String @@ -601,12 +601,12 @@ return () Just p -> do ideR <- ask - reifyIDE (\ideR session -> catch (do + reifyIDE (\ideR -> catch (do gpd <- readPackageDescription normal (cabalFile p) if hasConfigs gpd then do reflectIDE (ideMessage High - "Cabal File with configurations can't be automatically updated") ideR session + "Cabal File with configurations can't be automatically updated") ideR else let pd = flattenPackageDescription gpd npd = if isExposed && isJust (library pd) @@ -621,7 +621,7 @@ (executables npd1)} in writePackageDescription (cabalFile p) npd) (\(e :: SomeException) -> do - reflectIDE (ideMessage Normal ("Can't upade package " ++ show e)) ideR session + reflectIDE (ideMessage Normal ("Can't upade package " ++ show e)) ideR return ())) where addModToBuildInfo :: BuildInfo -> ModuleName -> BuildInfo diff --git a/src/IDE/Pane/Callers.hs b/src/IDE/Pane/Callers.hs --- a/src/IDE/Pane/Callers.hs +++ b/src/IDE/Pane/Callers.hs @@ -151,7 +151,7 @@ paneMap <- readIDE paneMap prefs <- readIDE prefs currentInfo <- readIDE currentInfo - (buf,cids) <- reifyIDE $ \ideR session -> do + (buf,cids) <- reifyIDE $ \ideR -> do listStore <- New.listStoreNew [] treeView <- New.treeViewNew New.treeViewSetModel treeView listStore @@ -204,8 +204,8 @@ notebookInsertOrdered nb box (paneName callers) Nothing widgetShowAll box cid1 <- treeView `afterFocusIn` - (\_ -> do reflectIDE (makeActive callers) ideR session; return True) - treeView `onButtonPress` (treeViewPopup ideR session callers) + (\_ -> do reflectIDE (makeActive callers) ideR ; return True) + treeView `onButtonPress` (treeViewPopup ideR callers) return (callers,[ConnectC cid1]) addPaneAdmin buf cids panePath liftIO $widgetGrabFocus (scrolledView buf) @@ -224,11 +224,10 @@ _ -> return Nothing treeViewPopup :: IDERef - -> Session -> IDECallers -> Event -> IO (Bool) -treeViewPopup ideR session callers (Button _ click _ _ _ _ button _ _) = do +treeViewPopup ideR callers (Button _ click _ _ _ _ button _ _) = do if button == RightButton then do theMenu <- menuNew @@ -242,7 +241,7 @@ text <- entryGetText (callersEntry callers) case words text of (hd : tl) -> do - reflectIDE (selectText fp hd) ideR session + reflectIDE (selectText fp hd) ideR return () _ -> return () otherwise -> return () @@ -261,12 +260,12 @@ text <- entryGetText (callersEntry callers) case words text of (hd : tl) -> do - reflectIDE (selectText fp hd) ideR session + reflectIDE (selectText fp hd) ideR return True _ -> return False otherwise -> return False else return False -treeViewPopup _ _ _ _ = throwIDE "treeViewPopup wrong event type" +treeViewPopup _ _ _ = throwIDE "treeViewPopup wrong event type" selectText :: FilePath -> String -> IDEM Bool selectText fp text = do @@ -278,9 +277,9 @@ setFindState fs {entryStr = text} showFindbar focusFindEntry - reifyIDE $ \ideR session -> do + reifyIDE $ \ideR -> do idleAdd (do - reflectIDE (editFind True True True text "" Forward) ideR session + reflectIDE (editFind True True True text "" Forward) ideR return False) priorityDefaultIdle return True diff --git a/src/IDE/Pane/ClassHierarchy.hs b/src/IDE/Pane/ClassHierarchy.hs --- a/src/IDE/Pane/ClassHierarchy.hs +++ b/src/IDE/Pane/ClassHierarchy.hs @@ -262,7 +262,7 @@ paneMap <- readIDE paneMap prefs <- readIDE prefs currentInfo <- readIDE currentInfo - (buf,cids) <- reifyIDE $ \ideR session -> do + (buf,cids) <- reifyIDE $ \ideR -> do -- Class Hierarchy let forest = case currentInfo of @@ -366,7 +366,7 @@ New.treeViewExpandRow treeView treePath False return ()) cid1 <- treeView `afterFocusIn` - (\_ -> do reflectIDE (makeActive classes) ideR session; return True) + (\_ -> do reflectIDE (makeActive classes) ideR; return True) -- cid2 <- facetView `afterFocusIn` -- (\_ -> do runReaderT (makeActive classes) ideR; return True) -- treeView `onButtonPress` (treeViewPopup ideR treeStore treeView) diff --git a/src/IDE/Pane/Info.hs b/src/IDE/Pane/Info.hs --- a/src/IDE/Pane/Info.hs +++ b/src/IDE/Pane/Info.hs @@ -101,8 +101,8 @@ Nothing -> return () Just p -> liftIO $ bringPaneToFront p -idDescrDescr :: IDERef -> Session -> FieldDescription Descr -idDescrDescr ideR session = VFD emptyParams [ +idDescrDescr :: IDERef -> FieldDescription Descr +idDescrDescr ideR = VFD emptyParams [ HFD emptyParams [ mkField (paraName <<<- ParaName "Identifier" @@ -110,7 +110,7 @@ $ emptyParams) descrName (\ b a -> if isReexported a then a else a{descrName' = b}) - (symbolEditor ideR session) + (symbolEditor ideR ) , mkField emptyParams (stockIdFromType . descrType . details) @@ -142,22 +142,22 @@ mbComment' = case snd b of "" -> Nothing s -> Just (BS.pack s)})) - (typeAndCommentEditor ideR session)] + (typeAndCommentEditor ideR )] --allIdTypes = [Function, Newtype, Type, AbstractData, OpenData, Foreign -- , Data, Class, Instance, Constructor, Field, Method, OrphanedInstance] -typeEditor :: IDERef -> Session -> Editor String -typeEditor ideR session para noti = do +typeEditor :: IDERef -> Editor String +typeEditor ideR para noti = do ed@(wid,inj,ext) <- multilineStringEditor para noti registerEvent noti ButtonRelease $Left (\e -> do - res <- showInfoHandler wid ideR session + res <- showInfoHandler wid ideR return e {gtkReturn = res}) return ed -typeAndCommentEditor :: IDERef -> Session -> Editor (String,String) -typeAndCommentEditor ideR session para noti = - splitEditor (typeEditor ideR session, +typeAndCommentEditor :: IDERef -> Editor (String,String) +typeAndCommentEditor ideR para noti = + splitEditor (typeEditor ideR, paraName <<<- ParaName "Type" $ paraOuterPadding <<<- ParaOuterPadding (0, 0, 0, 0) $ paraInnerPadding <<<- ParaInnerPadding (0, 0, 0, 0) @@ -171,9 +171,9 @@ $ paraInnerPadding <<<- ParaInnerPadding (0, 0, 0, 0) $ para) noti -symbolEditor :: IDERef -> Session -> Editor String -symbolEditor ideR session parameters notifier = do - window <- reflectIDE (readIDE window) ideR session +symbolEditor :: IDERef -> Editor String +symbolEditor ideR parameters notifier = do + window <- reflectIDE (readIDE window) ideR ed@(w,i,ext) <- stringEditor (\_ -> True) parameters notifier registerEvent notifier AfterKeyRelease (Left (\ event -> do mbText <- ext @@ -181,7 +181,7 @@ Just t -> do reflectIDE (do triggerEvent ideR (SearchMeta t) - return ()) ideR session + return ()) ideR rw <- liftIO $ getRealWidget w when (isJust rw) $ liftIO $ do widgetGrabFocus (fromJust rw) @@ -191,8 +191,8 @@ return event{gtkReturn=False})) return ed -showInfoHandler :: Widget -> IDERef -> Session -> IO Bool -showInfoHandler wid ideR session = do +showInfoHandler :: Widget -> IDERef -> IO Bool +showInfoHandler wid ideR = do mbFrame <- binGetChild (castToAlignment wid) mbInner <- binGetChild (castToFrame (forceJust mbFrame "InfoPane>>typeEditor: Can't find child")) mbScrolled <- binGetChild (castToAlignment (forceJust mbInner "InfoPane>>typeEditor: Can't find child2")) @@ -200,7 +200,7 @@ buf <- textViewGetBuffer (castToTextView (forceJust mbTV "InfoPane>>typeEditor: Can't find child4")) (l,r) <- textBufferGetSelectionBounds buf symbol <- textBufferGetText buf l r True - reflectIDE (triggerEvent ideR (SelectInfo symbol)) ideR session + reflectIDE (triggerEvent ideR (SelectInfo symbol)) ideR return False initInfo :: PanePath -> Notebook -> Descr -> IDEAction @@ -208,7 +208,7 @@ panes <- readIDE panes paneMap <- readIDE paneMap prefs <- readIDE prefs - (pane,cids) <- reifyIDE $ \ideR session -> do + (pane,cids) <- reifyIDE $ \ideR -> do ibox <- vBoxNew False 0 bb <- hButtonBoxNew buttonBoxSetLayout bb ButtonboxSpread @@ -223,7 +223,7 @@ boxPackStartDefaults bb usesB boxPackStartDefaults bb docuB boxPackStartDefaults bb searchB - (widget,injb,ext,notifier) <- buildEditor (idDescrDescr ideR session) idDescr + (widget,injb,ext,notifier) <- buildEditor (idDescrDescr ideR ) idDescr boxPackStart ibox widget PackGrow 0 boxPackEnd ibox bb PackNatural 0 --openType @@ -233,18 +233,18 @@ currentDescr' <- newIORef idDescr let info = IDEInfo sw currentDescr' injb ext -- mapM_ (\w -> widgetSetExtensionEvents w [ExtensionEventsAll]) widgets --- widget `onFocus` (\_ -> do reflectIDE (makeActive info) ideR session +-- widget `onFocus` (\_ -> do reflectIDE (makeActive info) ideR -- return False) - definitionB `onClicked` (reflectIDE gotoSource ideR session) - moduB `onClicked` (reflectIDE gotoModule' ideR session) - usesB `onClicked` (reflectIDE calledBy' ideR session) + definitionB `onClicked` (reflectIDE gotoSource ideR ) + moduB `onClicked` (reflectIDE gotoModule' ideR ) + usesB `onClicked` (reflectIDE calledBy' ideR ) searchB `onClicked` (do mbDescr <- ext idDescr case mbDescr of Nothing -> return () Just descr -> reflectIDE (do triggerEvent ideR (SearchMeta (descrName' descr)) - showInfo) ideR session) + showInfo) ideR ) notebookInsertOrdered nb sw (paneName info) Nothing widgetShowAll sw return (info,[]) 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 @@ -142,7 +142,7 @@ panes <- readIDE panes paneMap <- readIDE paneMap prefs <- readIDE prefs - (buf,cids) <- reifyIDE $ \ideR session -> do + (buf,cids) <- reifyIDE $ \ideR -> do tv <- textViewNew buf <- textViewGetBuffer tv iter <- textBufferGetEndIter buf @@ -177,9 +177,9 @@ notebookInsertOrdered nb sw (paneName buf) Nothing widgetShowAll (scrolledWindowL buf) cid1 <- tv `afterFocusIn` - (\_ -> do reflectIDE (makeActive buf) ideR session; return True) + (\_ -> do reflectIDE (makeActive buf) ideR ; return True) cid2 <- tv `onButtonPress` - (\ b -> do reflectIDE (clicked b buf) ideR session; return True) + (\ b -> do reflectIDE (clicked b buf) ideR ; return True) return (buf,[ConnectC cid1, ConnectC cid2]) addPaneAdmin buf cids panePath liftIO $widgetGrabFocus (textView buf) @@ -206,18 +206,18 @@ otherwise -> return () clicked (Button _ SingleClick _ _ _ _ RightButton x y) ideLog = do errors' <- readIDE errors - line' <- reifyIDE $ \ideR session -> do + line' <- reifyIDE $ \ideR -> do (x,y) <- widgetGetPointer (textView ideLog) (_,y') <- textViewWindowToBufferCoords (textView ideLog) TextWindowWidget (x,y) (iter,_) <- textViewGetLineAtY (textView ideLog) y' textIterGetLine iter case filter (\(es,_) -> fst (logLines es) <= (line'+1) && snd (logLines es) >= (line'+1)) (zip errors' [0..(length errors')]) of - [(thisErr,n)] -> reifyIDE $ \ideR session -> do + [(thisErr,n)] -> reifyIDE $ \ideR -> do theMenu <- menuNew item0 <- menuItemNewWithLabel "Add all imports" item0 `onActivateLeaf` do - reflectIDE addAllImports' ideR session + reflectIDE addAllImports' ideR menuShellAppend theMenu item0 case parseNotInScope (errDescription thisErr) of Nothing -> do @@ -225,7 +225,7 @@ Just _ -> do item1 <- menuItemNewWithLabel "Add import" item1 `onActivateLeaf` do - reflectIDE (addImport thisErr >> return()) ideR session + reflectIDE (addImport thisErr >> return()) ideR menuShellAppend theMenu item1 menuPopup theMenu Nothing widgetShowAll theMenu 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 @@ -257,7 +257,7 @@ paneMap <- readIDE paneMap prefs <- readIDE prefs currentInfo <- readIDE currentInfo - (buf,cids) <- reifyIDE $ \ideR session -> do + (buf,cids) <- reifyIDE $ \ideR -> do -- Modules List let forest = case currentInfo of Nothing -> [] @@ -372,24 +372,24 @@ New.treeViewExpandRow treeView treePath False return ()) cid1 <- treeView `afterFocusIn` - (\_ -> do reflectIDE (makeActive modules) ideR session; return True) + (\_ -> do reflectIDE (makeActive modules) ideR; return True) cid2 <- descrView `afterFocusIn` - (\_ -> do reflectIDE (makeActive modules) ideR session; return True) - treeView `onButtonPress` (treeViewPopup ideR session treeStore treeView) - descrView `onButtonPress` (descrViewPopup ideR session descrStore descrView) - rb1 `onToggled` (reflectIDE scopeSelection ideR session) - rb2 `onToggled` (reflectIDE scopeSelection ideR session) - rb3 `onToggled` (reflectIDE scopeSelection ideR session) - cb `onToggled` (reflectIDE scopeSelection ideR session) + (\_ -> do reflectIDE (makeActive modules) ideR; return True) + treeView `onButtonPress` (treeViewPopup ideR treeStore treeView) + descrView `onButtonPress` (descrViewPopup ideR descrStore descrView) + rb1 `onToggled` (reflectIDE scopeSelection ideR) + rb2 `onToggled` (reflectIDE scopeSelection ideR) + rb3 `onToggled` (reflectIDE scopeSelection ideR) + cb `onToggled` (reflectIDE scopeSelection ideR) sel <- New.treeViewGetSelection treeView sel `New.onSelectionChanged` do fillFacets treeView treeStore descrView descrStore - reflectIDE recordSelHistory ideR session + reflectIDE recordSelHistory ideR return () sel2 <- New.treeViewGetSelection descrView sel2 `New.onSelectionChanged` do - fillInfo descrView descrStore ideR session - reflectIDE recordSelHistory ideR session + fillInfo descrView descrStore ideR + reflectIDE recordSelHistory ideR return () return (modules,[ConnectC cid1,ConnectC cid2, ConnectC cid3]) addPaneAdmin buf cids panePath @@ -502,16 +502,15 @@ fillInfo :: New.TreeView -> New.TreeStore Descr -> IDERef - -> Session -> IO () -fillInfo treeView lst ideR session = do +fillInfo treeView lst ideR = do treeSelection <- New.treeViewGetSelection treeView paths <- New.treeSelectionGetSelectedRows treeSelection case paths of [] -> return () [a] -> do descr <- New.treeStoreGetValue lst a - reflectIDE (setInfo descr) ideR session + reflectIDE (setInfo descr) ideR return () _ -> return () @@ -720,12 +719,11 @@ sortTree (Node l forest) = Node l (sort (map sortTree forest)) treeViewPopup :: IDERef - -> Session -> New.TreeStore (String, [(ModuleDescr,PackageDescr)]) -> New.TreeView -> Event -> IO (Bool) -treeViewPopup ideR session store treeView (Button _ click _ _ _ _ button _ _) = do +treeViewPopup ideR store treeView (Button _ click _ _ _ _ button _ _) = do if button == RightButton then do theMenu <- menuNew @@ -736,7 +734,7 @@ Just (_,[(m,_)]) -> case mbSourcePathMD m of Nothing -> return () Just fp -> do - reflectIDE (selectSourceBuf fp) ideR session + reflectIDE (selectSourceBuf fp) ideR return () otherwise -> return () sep1 <- separatorMenuItemNew @@ -750,7 +748,7 @@ item5 `onActivateLeaf` (New.treeViewCollapseAll treeView) sep2 <- separatorMenuItemNew item6 <- menuItemNewWithLabel "Add module" - item6 `onActivateLeaf` (reflectIDE (addModule treeView store) ideR session) + item6 `onActivateLeaf` (reflectIDE (addModule treeView store) ideR) mapM_ (menuShellAppend theMenu) [castToMenuItem item1, castToMenuItem sep1, castToMenuItem item2, castToMenuItem item3, castToMenuItem item4, castToMenuItem item5, castToMenuItem sep2, @@ -764,20 +762,19 @@ Just (_,[(m,_)]) -> case mbSourcePathMD m of Nothing -> return () Just fp -> do - reflectIDE (selectSourceBuf fp) ideR session + reflectIDE (selectSourceBuf fp) ideR return () otherwise -> return () return True else return False -treeViewPopup _ _ _ _ _ = throwIDE "treeViewPopup wrong event type" +treeViewPopup _ _ _ _ = throwIDE "treeViewPopup wrong event type" descrViewPopup :: IDERef - -> Session -> New.TreeStore Descr -> New.TreeView -> Event -> IO (Bool) -descrViewPopup ideR session store descrView (Button _ click _ _ _ _ button _ _) = do +descrViewPopup ideR store descrView (Button _ click _ _ _ _ button _ _) = do if button == RightButton then do theMenu <- menuNew @@ -785,8 +782,7 @@ item1 `onActivateLeaf` do sel <- getSelectionDescr descrView store case sel of - Just descr -> reflectIDE - (goToDefinition descr) ideR session + Just descr -> reflectIDE (goToDefinition descr) ideR otherwise -> sysMessage Normal "Modules>> descrViewPopup: no selection" menuShellAppend theMenu item1 menuPopup theMenu Nothing @@ -795,15 +791,15 @@ else if button == LeftButton && click == DoubleClick then do sel <- getSelectionDescr descrView store case sel of - Just descr -> reflectIDE (goToDefinition descr) ideR session + Just descr -> reflectIDE (goToDefinition descr) ideR otherwise -> sysMessage Normal "Modules>> descrViewPopup: no selection2" return True else do - mbPane :: Maybe IDEInfo <- reflectIDE getPane ideR session + mbPane :: Maybe IDEInfo <- reflectIDE getPane ideR when (isJust mbPane) $ bringPaneToFront (fromJust mbPane) return False -descrViewPopup _ _ _ _ _ = throwIDE "descrViewPopup wrong event type" +descrViewPopup _ _ _ _ = throwIDE "descrViewPopup wrong event type" setScope :: (Scope,Bool) -> IDEAction setScope (sc,bl) = do 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 @@ -43,7 +43,6 @@ import Distribution.ModuleName(ModuleName) import Data.Typeable (Typeable(..)) import Debug.Trace (trace) -import IDE.Metainfo.InterfaceCollector (getInstalledPackageInfos) import qualified Distribution.InstalledPackageInfo as IPI (package) import Graphics.UI.Editor.Composite (maybeEditor,pairEditor,ColumnDescr(..),multisetEditor) import qualified Graphics.UI.Gtk as New (cellText) @@ -52,6 +51,7 @@ import Graphics.UI.Editor.Parameters (Parameter(..),paraPack,Direction(..),paraDirection,paraMinSize,paraShadow,paraSynopsis,(<<<-),emptyParams,paraName,getParameterPrim) import Graphics.UI.Editor.Simple (boolEditor,fileEditor,comboSelectionEditor,multilineStringEditor,stringEditor) import Distribution.License (License(..)) +import IDE.Metainfo.GHCUtils (inGhc,getInstalledPackageInfos) -- --------------------------------------------------------------------- -- The exported stuff goes here @@ -257,7 +257,7 @@ layout <- readIDE layout let pp = getStandardPanePath (sourcePanePath prefs) layout nb <- getNotebook pp - packageInfos <- lift $ getInstalledPackageInfos + packageInfos <- inGhc $ getInstalledPackageInfos let packageEd = toEditor packageD initPackage packagePath packageEd (packageDD @@ -286,8 +286,8 @@ window <- readIDE window paneMap <- readIDE paneMap currentInfo <- readIDE currentInfo - packageInfos <- lift $ getInstalledPackageInfos - (buf,cids) <- reifyIDE $ \ideR session -> do + packageInfos <- inGhc $ getInstalledPackageInfos + (buf,cids) <- reifyIDE $ \ideR -> do vb <- vBoxNew False 0 let packagePane = PackagePane vb bb <- hButtonBoxNew @@ -313,7 +313,7 @@ let packagePath = packageDir (display . pkgName . package . pd) newPackage' ++ ".cabal" writePackageDescription packagePath newPackage - reflectIDE (afterSaveAction packagePath) ideR session) + reflectIDE (afterSaveAction packagePath) ideR) closeB `onClicked` (do mbNewPackage' <- extractAndValidate packageD [getExt] fieldNames case mbNewPackage' of @@ -323,7 +323,7 @@ rid <- dialogRun md widgetDestroy md case rid of - ResponseYes -> (reflectIDE (close packagePane) ideR session) + ResponseYes -> (reflectIDE (close packagePane) ideR) otherwise -> return () Just newPackage -> do let packagePath = packageDir (display . pkgName . package . pd) newPackage @@ -363,7 +363,7 @@ ResponseNo -> return False _ -> return False else return False - when (not cancel) (reflectIDE (close packagePane) ideR session)) + when (not cancel) (reflectIDE (close packagePane) ideR)) restore `onClicked` (do package <- readPackageDescription normal initialPackagePath setInj (toEditor (flattenPackageDescription package))) @@ -382,7 +382,7 @@ (length (bis pde) + 1) (concatMap (buildInfoD (Just packageDir) modules) [0..length (bis pde)])) - panePath nb2 modules afterSaveAction) ideR session) + panePath nb2 modules afterSaveAction) ideR) removeB `onClicked` (do mbNewPackage' <- extractAndValidate packageD [getExt] fieldNames case mbNewPackage' of @@ -398,7 +398,7 @@ (length (bis pde) - 1) (concatMap (buildInfoD (Just packageDir) modules) [0..length (bis pde) - 2])) - panePath nb2 modules afterSaveAction) ideR session) + panePath nb2 modules afterSaveAction) ideR) boxPackStart vb widget PackGrow 7 boxPackEnd vb bb PackNatural 7 widgetShowAll vb diff --git a/src/IDE/Pane/PackageFlags.hs b/src/IDE/Pane/PackageFlags.hs --- a/src/IDE/Pane/PackageFlags.hs +++ b/src/IDE/Pane/PackageFlags.hs @@ -229,7 +229,7 @@ initFlags idePackage panePath nb = do let flagsDesc = extractFieldDescription flagsDescription let flatflagsDesc = flattenFieldDescription flagsDesc - (buf,cids) <- reifyIDE $ \ ideR session -> do + (buf,cids) <- reifyIDE $ \ ideR -> do vb <- vBoxNew False 0 let flagsPane = IDEFlags vb bb <- hButtonBoxNew @@ -249,12 +249,12 @@ Just packWithNewFlags -> do reflectIDE (do modifyIDE_ (\ide -> return (ide{activePack = Just packWithNewFlags})) - close flagsPane) ideR session -- we don't trigger the activePack event here + close flagsPane) ideR -- we don't trigger the activePack event here writeFlags ((dropFileName (cabalFile packWithNewFlags)) "IDE.flags") packWithNewFlags) - closeB `onClicked` (reflectIDE (close flagsPane) ideR session) + closeB `onClicked` (reflectIDE (close flagsPane) ideR) registerEvent notifier FocusIn (Left (\e -> do - reflectIDE (makeActive flagsPane) ideR session + reflectIDE (makeActive flagsPane) ideR return (e{gtkReturn=False}))) boxPackStart vb sw PackGrow 7 boxPackEnd vb bb PackNatural 7 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 @@ -52,6 +52,7 @@ import IDE.FileUtils import System.IO import Distribution.InstalledPackageInfo (package) +import IDE.Metainfo.GHCUtils (getInstalledPackageInfos,inGhc) -- -- | The Preferences Pane @@ -123,14 +124,14 @@ initPrefs :: PanePath -> Notebook -> IDEAction initPrefs panePath nb2 = do - packageInfos <- lift $ getInstalledPackageInfos + packageInfos <- inGhc getInstalledPackageInfos let flatPrefsDesc = flattenFieldDescriptionPP (prefsDescription (map package packageInfos)) prefs <- readIDE prefs lastAppliedPrefsRef <- liftIO $ newIORef prefs panes <- readIDE panes paneMap <- readIDE paneMap currentInfo <- readIDE currentInfo - (buf,cids) <- reifyIDE $ \ideR session -> do + (buf,cids) <- reifyIDE $ \ideR -> do vb <- vBoxNew False 0 bb <- hButtonBoxNew apply <- buttonNewFromStock "gtk-apply" @@ -151,11 +152,11 @@ Nothing -> return () Just newPrefs -> do lastAppliedPrefs <- readIORef lastAppliedPrefsRef - mapM_ (\ (FDPP _ _ _ _ applyF) -> reflectIDE (applyF newPrefs lastAppliedPrefs) ideR session) flatPrefsDesc + mapM_ (\ (FDPP _ _ _ _ applyF) -> reflectIDE (applyF newPrefs lastAppliedPrefs) ideR ) flatPrefsDesc writeIORef lastAppliedPrefsRef newPrefs) restore `onClicked` (do lastAppliedPrefs <- readIORef lastAppliedPrefsRef - mapM_ (\ (FDPP _ _ _ _ applyF) -> reflectIDE (applyF prefs lastAppliedPrefs) ideR session) flatPrefsDesc + mapM_ (\ (FDPP _ _ _ _ applyF) -> reflectIDE (applyF prefs lastAppliedPrefs) ideR ) flatPrefsDesc injb prefs writeIORef lastAppliedPrefsRef prefs) save `onClicked` (do @@ -164,13 +165,13 @@ case mbNewPrefs of Nothing -> return () Just newPrefs -> do - mapM_ (\ (FDPP _ _ _ _ applyF) -> reflectIDE (applyF newPrefs lastAppliedPrefs) ideR session) flatPrefsDesc + mapM_ (\ (FDPP _ _ _ _ applyF) -> reflectIDE (applyF newPrefs lastAppliedPrefs) ideR ) flatPrefsDesc fp <- getConfigFilePathForSave "Default.prefs" writePrefs fp newPrefs - reflectIDE (modifyIDE_ (\ide -> return (ide{prefs = newPrefs}))) ideR session) - closeB `onClicked` (reflectIDE (close prefsPane) ideR session) + reflectIDE (modifyIDE_ (\ide -> return (ide{prefs = newPrefs}))) ideR ) + closeB `onClicked` (reflectIDE (close prefsPane) ideR ) registerEvent notifier FocusIn (Left (\e -> do - reflectIDE (makeActive prefsPane) ideR session + reflectIDE (makeActive prefsPane) ideR return (e{gtkReturn=False}))) notebookInsertOrdered nb2 vb (paneName prefsPane) Nothing widgetShowAll vb @@ -196,7 +197,7 @@ boolEditor (\b -> do buffers <- allBuffers - mapM_ (\buf -> liftIO$sourceViewSetShowLineNumbers (sourceView buf) b) buffers) + mapM_ (\buf -> liftIO $ sourceViewSetShowLineNumbers (sourceView buf) b) buffers) , mkFieldPP (paraName <<<- ParaName "TextView Font" $ emptyParams) (\a -> PP.text (case a of Nothing -> show ""; Just s -> show s)) @@ -207,7 +208,7 @@ fontEditor (\mbs -> do buffers <- allBuffers - fdesc <- liftIO $fontDescriptionFromString (case mbs of Just str -> str; Nothing -> "") + fdesc <- liftIO $ fontDescriptionFromString (case mbs of Just str -> str; Nothing -> "") liftIO $mapM_ (\buf -> widgetModifyFont (castToWidget $sourceView buf) (Just fdesc)) buffers) , mkFieldPP (paraName <<<- ParaName "Right margin" 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 @@ -123,7 +123,7 @@ paneMap <- readIDE paneMap prefs <- readIDE prefs currentInfo <- readIDE currentInfo - (buf,cids) <- reifyIDE $ \ideR session -> do + (buf,cids) <- reifyIDE $ \ideR -> do scopebox <- hBoxNew True 2 rb1 <- radioButtonNewWithLabel "Local" @@ -227,28 +227,28 @@ widgetShowAll box cid1 <- treeView `afterFocusIn` - (\_ -> do reflectIDE (makeActive search) ideR session; return True) - rb1 `onToggled` (reflectIDE (scopeSelection Local) ideR session) - rb2 `onToggled` (reflectIDE (scopeSelection Package) ideR session) - rb3 `onToggled` (reflectIDE (scopeSelection System) ideR session) + (\_ -> do reflectIDE (makeActive search) ideR ; return True) + rb1 `onToggled` (reflectIDE (scopeSelection Local) ideR ) + rb2 `onToggled` (reflectIDE (scopeSelection Package) ideR ) + rb3 `onToggled` (reflectIDE (scopeSelection System) ideR ) mb1 `onToggled` do widgetSetSensitivity mb4 False active <- toggleButtonGetActive mb4 - (reflectIDE (modeSelection (Exact active)) ideR session) + (reflectIDE (modeSelection (Exact active)) ideR ) mb2 `onToggled`do widgetSetSensitivity mb4 True active <- toggleButtonGetActive mb4 - (reflectIDE (modeSelection (Prefix active)) ideR session) + (reflectIDE (modeSelection (Prefix active)) ideR ) mb3 `onToggled` do widgetSetSensitivity mb4 True active <- toggleButtonGetActive mb4 - (reflectIDE (modeSelection (Regex active)) ideR session) + (reflectIDE (modeSelection (Regex active)) ideR ) mb4 `onToggled` do active <- toggleButtonGetActive mb4 - (reflectIDE (modeSelectionCase active) ideR session) - treeView `onButtonPress` (listViewPopup ideR session listStore treeView) + (reflectIDE (modeSelectionCase active) ideR ) + treeView `onButtonPress` (listViewPopup ideR listStore treeView) sel `New.onSelectionChanged` do - fillInfo treeView listStore ideR session + fillInfo treeView listStore ideR trace "search pane selection changes" $ return () return (search,[ConnectC cid1]) addPaneAdmin buf cids panePath @@ -298,12 +298,11 @@ mapM_ (New.listStoreAppend (searchStore search)) descrs listViewPopup :: IDERef - -> Session -> New.ListStore Descr -> New.TreeView -> Event -> IO (Bool) -listViewPopup ideR session store descrView (Button _ click _ _ _ _ button _ _) = do +listViewPopup ideR store descrView (Button _ click _ _ _ _ button _ _) = do if button == RightButton then do theMenu <- menuNew @@ -312,7 +311,7 @@ sel <- getSelectionDescr descrView store case sel of Just descr -> reflectIDE - (goToDefinition descr) ideR session + (goToDefinition descr) ideR otherwise -> sysMessage Normal "Search >> listViewPopup: no selection" menuShellAppend theMenu item1 menuPopup theMenu Nothing @@ -322,14 +321,14 @@ then do sel <- getSelectionDescr descrView store case sel of Just descr -> reflectIDE (triggerEvent ideR (SelectIdent descr)) - ideR session >> return () + ideR >> return () otherwise -> sysMessage Normal "Search >> listViewPopup: no selection2" return True else do - mbPane :: Maybe IDEInfo <- reflectIDE getPane ideR session + mbPane :: Maybe IDEInfo <- reflectIDE getPane ideR when (isJust mbPane) $ bringPaneToFront (fromJust mbPane) return False -listViewPopup _ _ _ _ _ = throwIDE "listViewPopup wrong event type" +listViewPopup _ _ _ _ = throwIDE "listViewPopup wrong event type" getSelectionDescr :: New.TreeView -> New.ListStore Descr @@ -346,12 +345,11 @@ fillInfo :: New.TreeView -> New.ListStore Descr -> IDERef - -> Session -> IO () -fillInfo treeView listStore ideR session = do +fillInfo treeView listStore ideR = do sel <- getSelectionDescr treeView listStore case sel of - Just descr -> reflectIDE (setInfo descr) ideR session + Just descr -> reflectIDE (setInfo descr) ideR otherwise -> sysMessage Normal "Search>>fillInfo:no selection" setChoices :: [Descr] -> IDEAction 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 @@ -116,12 +116,12 @@ sbIO <- getStatusbarIO infos <- readIDE accessibleInfo let sv = sourceView actbuf - (cids) <- reifyIDE $ \ideR session -> do + (cids) <- reifyIDE $ \ideR -> do gtkBuf <- textViewGetBuffer sv bringPaneToFront actbuf writeCursorPositionInStatusbar sv sbLC writeOverwriteInStatusbar sv sbIO - id1 <- gtkBuf `afterModifiedChanged` reflectIDE (markLabelAsChanged) ideR session + id1 <- gtkBuf `afterModifiedChanged` reflectIDE (markLabelAsChanged) ideR id2 <- sv `afterMoveCursor` (\_ _ _ -> writeCursorPositionInStatusbar sv sbLC) id3 <- gtkBuf `afterEndUserAction` writeCursorPositionInStatusbar sv sbLC @@ -129,7 +129,7 @@ id5 <- sv `onButtonRelease` (\ e -> do writeCursorPositionInStatusbar sv sbLC - when (controlIsPressed e) $ showInfo sv ideR session + when (controlIsPressed e) $ showInfo sv ideR return False) id6 <- sv `afterToggleOverwrite` writeOverwriteInStatusbar sv sbIO return [ConnectC id2,ConnectC id6,ConnectC id1,ConnectC id3] @@ -290,7 +290,7 @@ bs <- getCandyState ct <- readIDE candy let (ind,rbn) = figureOutPaneName panes bn 0 - (buf,cids) <- reifyIDE $ \ideR session -> do + (buf,cids) <- reifyIDE $ \ideR -> do lm <- sourceLanguageManagerNew (mbLanguage, mbSLang) <- sourceLanguageForFilename lm mbfn @@ -326,7 +326,6 @@ -- create a new SourceView Widget sv <- sourceViewNewWithBuffer buffer - set sv [sourceViewHighlightCurrentLine := True] fd <- case textviewFont prefs of Just str -> do fontDescriptionFromString str @@ -335,6 +334,7 @@ fontDescriptionSetFamily f "Monospace" return f widgetModifyFont sv (Just fd) + set sv [sourceViewHighlightCurrentLine := True] sourceViewSetShowLineNumbers sv (showLineNumbers prefs) case rightMargin prefs of Just n -> do @@ -366,11 +366,19 @@ notebookInsertOrdered nb sw rbn Nothing -- events cid <- sv `afterFocusIn` - (\_ -> do reflectIDE (makeActive buf) ideR session; return False) + (\_ -> do reflectIDE (makeActive buf) ideR ; return False) return (buf,[cid]) addPaneAdmin buf (map ConnectC cids) panePath - liftIO $widgetShowAll (scrolledWindow buf) - liftIO $widgetGrabFocus (sourceView buf) + liftIO $do + widgetShowAll (scrolledWindow buf) + widgetGrabFocus (sourceView buf) +-- patch for windows + fdesc <- fontDescriptionFromString (case textviewFont prefs of Just str -> str; Nothing -> "") + fds <- fontDescriptionGetSize fdesc + when (isJust fds) $ do + fontDescriptionSetSize fdesc (fromJust fds + 0.01) + widgetModifyFont (castToWidget $ sourceView buf) (Just fdesc) +-- end patch return buf checkModTime :: IDEBuffer -> IDEAction @@ -468,12 +476,12 @@ return () -showInfo :: SourceView -> IDERef -> Session -> IO () -showInfo sv ideR session = do +showInfo :: SourceView -> IDERef -> IO () +showInfo sv ideR = do buf <- textViewGetBuffer sv (l,r) <- textBufferGetSelectionBounds buf symbol <- textBufferGetText buf l r True - reflectIDE (triggerEvent ideR (SelectInfo symbol)) ideR session + reflectIDE (triggerEvent ideR (SelectInfo symbol)) ideR return () markLabelAsChanged :: IDEAction @@ -540,7 +548,7 @@ liftIO $fileSave' (forceLineEnds prefs) (removeTBlanks prefs) currentBuffer bs candy $fromJust mbfn setModTime currentBuffer return () - else reifyIDE $ \ideR session -> do + else reifyIDE $ \ideR -> do dialog <- fileChooserDialogNew (Just $ "Save File") (Just window) @@ -578,7 +586,7 @@ reflectIDE (do close currentBuffer newTextBuffer panePath (takeFileName fn) (Just cfn) - ) ideR session + ) ideR return () ResponseNo -> return () _ -> return () @@ -613,7 +621,7 @@ window <- readIDE window bufs <- readIDE panes paneMap <- readIDE paneMap - cancel <- reifyIDE $ \ideR session -> do + cancel <- reifyIDE $ \ideR -> do modified <- textBufferGetModified gtkbuf if modified then do @@ -630,7 +638,7 @@ widgetDestroy md case resp of ResponseYes -> do - reflectIDE (fileSave False) ideR session + reflectIDE (fileSave False) ideR return False ResponseCancel -> return True ResponseNo -> return False @@ -640,6 +648,7 @@ then return False else do deactivatePane + modifyIDE_ (\ide -> return (ide{lastActiveBufferPane = Nothing})) removePaneAdmin currentBuffer liftIO $ do notebookRemovePage nb i