diff --git a/ltk.cabal b/ltk.cabal --- a/ltk.cabal +++ b/ltk.cabal @@ -1,36 +1,45 @@ -name: ltk -version: 0.12.1.0 -cabal-version: >= 1.8 -build-type: Simple -license: GPL -license-file: LICENSE -copyright: Juergen "jutaro" Nicklisch-Franken -maintainer: maintainer@leksah.org -homepage: http://www.leksah.org -package-url: http://code.haskell.org/ltk -bug-reports: http://code.google.com/p/leksah/issues/list -synopsis: Leksah tool kit -description: UI Framework used by leksah -category: GUI -author: Juergen "jutaro" Nicklisch-Franken -tested-with: GHC ==6.10 || ==6.12 || ==7.0 - -Library - build-depends: Cabal >=1.6.0 && <1.15, base >=4.0.0.0 && <4.6, - containers >=0.2 && <0.5, filepath >=1.1.0 && <1.4, - glib >=0.10.0 && <0.13, gtk >=0.10.0 && <0.13, - mtl >=1.1.0.2 && <2.2, parsec >=2.1.0.1 && <3.2, - pretty >=1.0.1.0 && <1.2, transformers >=0.2.2.0 && <0.4, - ghc -any - - exposed-modules: Default MyMissing Control.Event - Graphics.UI.Editor.Basics Graphics.UI.Editor.Composite - Graphics.UI.Editor.DescriptionPP Graphics.UI.Editor.MakeEditor - Graphics.UI.Editor.Parameters Graphics.UI.Editor.Simple - Graphics.UI.Frame.Panes Graphics.UI.Frame.ViewFrame - Text.PrinterParser - exposed: True - buildable: True - extensions: CPP, FlexibleInstances, BangPatterns - hs-source-dirs: src - +name: ltk +version: 0.13.1.0 +cabal-version: >= 1.8 +build-type: Simple +license: GPL +license-file: LICENSE +copyright: Juergen "jutaro" Nicklisch-Franken +maintainer: maintainer@leksah.org +homepage: http://www.leksah.org +package-url: http://code.haskell.org/ltk +bug-reports: http://code.google.com/p/leksah/issues/list +synopsis: Leksah tool kit +description: UI Framework used by leksah +category: GUI +author: Juergen "jutaro" Nicklisch-Franken +tested-with: GHC ==6.10 || ==6.12 || ==7.0 + +Flag gtk3 + description: Use Gtk3 + default: True + +Library + build-depends: Cabal >=1.6.0 && <1.19, base >=4.0.0.0 && <4.8, + containers >=0.2 && <0.6, filepath >=1.1.0 && <1.4, + glib >=0.10.0 && <0.13, + mtl >=1.1.0.2 && <2.2, parsec >=2.1.0.1 && <3.2, + pretty >=1.0.1.0 && <1.2, transformers >=0.2.2.0 && <0.4, + ghc -any + + if flag(gtk3) + build-depends: gtk3 >=0.12.4 && <0.13 + cpp-options: -DMIN_VERSION_gtk=MIN_VERSION_gtk3 + else + build-depends: gtk >=0.12.4 && <0.13 + + exposed-modules: Default MyMissing Control.Event + Graphics.UI.Editor.Basics Graphics.UI.Editor.Composite + Graphics.UI.Editor.DescriptionPP Graphics.UI.Editor.MakeEditor + Graphics.UI.Editor.Parameters Graphics.UI.Editor.Simple + Graphics.UI.Frame.Panes Graphics.UI.Frame.ViewFrame + Text.PrinterParser + exposed: True + buildable: True + extensions: CPP, FlexibleInstances, BangPatterns + hs-source-dirs: src diff --git a/src/Graphics/UI/Editor/Basics.hs b/src/Graphics/UI/Editor/Basics.hs --- a/src/Graphics/UI/Editor/Basics.hs +++ b/src/Graphics/UI/Editor/Basics.hs @@ -1,5 +1,5 @@ -{-# OPTIONS_GHC -XMultiParamTypeClasses -XScopedTypeVariables -XFlexibleContexts -XRankNTypes - -XExistentialQuantification #-} +{-# LANGUAGE MultiParamTypeClasses, ScopedTypeVariables, FlexibleContexts, RankNTypes, + ExistentialQuantification, TypeFamilies, ImpredicativeTypes #-} ----------------------------------------------------------------------------- -- @@ -23,7 +23,6 @@ , Extractor , Applicator , Editor -, getStandardRegFunction , emptyNotifier , GUIEvent(..) , GUIEventSelector(..) @@ -41,10 +40,10 @@ ) where import Graphics.UI.Gtk -import qualified Graphics.UI.Gtk.Gdk.Events as Gtk import Data.Unique import Data.IORef import Control.Monad +import Control.Monad.Trans (liftIO) import Graphics.UI.Editor.Parameters import Control.Event @@ -93,7 +92,6 @@ -- data GUIEvent = GUIEvent { selector :: GUIEventSelector -, gtkEvent :: Gtk.Event , eventText :: String , gtkReturn :: Bool -- ^ True means that the event has been completely handled, -- gtk shoudn't do any further action about it (Often not @@ -124,7 +122,7 @@ -- | A type for handling an IO event -- Returning True: The event has been handles -- Returning False: Handling should proceed -type GtkHandler = Gtk.Event -> IO Bool +type GtkHandler = IO Bool -- -- | A type for a function to register a gtk event @@ -260,17 +258,17 @@ -- activateEvent - :: (GObjectClass o) => + :: GObjectClass o => o -> Notifier - -> Maybe (o -> GtkHandler -> IO Connection) + -> Maybe (o -> IO Bool -> IO Connection) -> GUIEventSelector -> IO () activateEvent widget (Noti pairRef) mbRegisterFunc eventSel = do let registerFunc = case mbRegisterFunc of Just f -> f Nothing -> getStandardRegFunction eventSel - cid <- registerFunc widget (\ e -> do + cid <- registerFunc widget (do (hi,_) <- readIORef pairRef case Map.lookup eventSel hi of Nothing -> return False @@ -280,7 +278,7 @@ then widgetGetName (castToWidget widget) else return "no widget - no name" eventList <- mapM (\f -> do - let ev = GUIEvent eventSel e "" False + let ev = GUIEvent eventSel "" False f ev) (map snd handlers) let boolList = map gtkReturn eventList @@ -297,12 +295,11 @@ -- | A convinence method for not repeating this over and over again -- getStandardRegFunction :: GUIEventSelector -> GtkRegFunc -getStandardRegFunction FocusOut = \w h -> liftM ConnectC $ (castToWidget w) `onFocusOut` h -getStandardRegFunction FocusIn = \w h -> liftM ConnectC $ (castToWidget w) `onFocusIn` h -getStandardRegFunction ButtonPressed = \w h -> liftM ConnectC $ (castToWidget w) `afterButtonRelease` h -getStandardRegFunction KeyPressed = \w h -> liftM ConnectC $ (castToWidget w) `afterKeyRelease` h -getStandardRegFunction Clicked = \w h -> liftM ConnectC $ (castToButton w) `onClicked` - (h (Gtk.Event True) >> return ()) +getStandardRegFunction FocusOut = \w h -> liftM ConnectC $ on (castToWidget w) focusOutEvent $ liftIO h +getStandardRegFunction FocusIn = \w h -> liftM ConnectC $ on (castToWidget w) focusInEvent $ liftIO h +getStandardRegFunction ButtonPressed = \w h -> liftM ConnectC $ after (castToWidget w) buttonReleaseEvent $ liftIO h +getStandardRegFunction KeyPressed = \w h -> liftM ConnectC $ after (castToWidget w) keyReleaseEvent $ liftIO h +getStandardRegFunction Clicked = \w h -> liftM ConnectC $ on (castToButton w) buttonActivated $ liftIO h >> return () getStandardRegFunction _ = error "Basic>>getStandardRegFunction: no original GUI event" registerEvents :: EventSource alpha beta gamma delta => alpha -> [delta] -> (beta -> gamma beta) -> gamma [Maybe Unique] diff --git a/src/Graphics/UI/Editor/Composite.hs b/src/Graphics/UI/Editor/Composite.hs --- a/src/Graphics/UI/Editor/Composite.hs +++ b/src/Graphics/UI/Editor/Composite.hs @@ -240,7 +240,7 @@ then do (childWidget,_,_) <- getChildEditor childRef childEdit childParams cNoti inj1 (not positive) - widgetHideAll childWidget + widgetHide childWidget else inj1 (not positive) Just val -> if hasChild @@ -286,7 +286,7 @@ hasChild <- hasChildEditor childRef when hasChild $ do (childWidget,_,_) <- getChildEditor childRef childEdit childParams cNoti - widgetHideAll childWidget + widgetHide childWidget else do hasChild <- hasChildEditor childRef (childWidget,inj2,ext2) <- getChildEditor childRef childEdit childParams cNoti @@ -584,12 +584,12 @@ activateEvent listStore notifier (Just (\ w h -> do res <- after (castToTreeModel w) rowInserted (\ _ _ -> - h (Gtk.Event True) >> return ()) + h >> return ()) return (ConnectC res))) MayHaveChanged activateEvent listStore notifier (Just (\ w h -> do res <- after (castToTreeModel w) rowDeleted (\ _ -> - h (Gtk.Event True) >> return ()) + h >> return ()) return (ConnectC res))) MayHaveChanged treeView <- treeViewNewWithModel listStore let minSize = getParameter paraMinSize parameters @@ -597,6 +597,9 @@ sw <- scrolledWindowNew Nothing Nothing containerAdd sw treeView scrolledWindowSetPolicy sw PolicyAutomatic PolicyAutomatic +#ifdef MIN_VERSION_gtk3 + scrolledWindowSetMinContentHeight sw (snd minSize) +#endif sel <- treeViewGetSelection treeView treeSelectionSetMode sel SelectionSingle mapM_ (\(str,func) -> do @@ -609,7 +612,7 @@ cellLayoutSetAttributes col renderer listStore func ) columnsDD treeViewSetHeadersVisible treeView showHeaders - sel `onSelectionChanged` selectionHandler sel listStore injS + on sel treeSelectionSelectionChanged $ selectionHandler sel listStore injS boxPackStart box sw PackGrow 0 boxPackStart box buttonBox PackNatural 0 boxPackStart box frameS PackNatural 0 @@ -620,7 +623,7 @@ (case mbSort of Nothing -> vs Just sortF -> sortF vs) - addButton `onClicked` do + on addButton buttonActivated $ do mbv <- extS case mbv of Just v -> do @@ -650,7 +653,7 @@ Just col -> treeViewScrollToCell treeView [idx] col Nothing Nothing -> return () Nothing -> return () - removeButton `onClicked` do + on removeButton buttonActivated $ do mbi <- treeSelectionGetSelected sel case mbi of Nothing -> return () @@ -777,6 +780,9 @@ (paraDirection <<<- ParaDirection Vertical $ para) noti let vrinj AnyVersion = inj Nothing +#if MIN_VERSION_Cabal(1,8,0) + vrinj (WildcardVersion v) = inj (Just (Left (WildcardVersionS,v))) +#endif vrinj (ThisVersion v) = inj (Just (Left (ThisVersionS,v))) vrinj (LaterVersion v) = inj (Just (Left (LaterVersionS,v))) vrinj (EarlierVersion v) = inj (Just (Left (EarlierVersionS,v))) @@ -796,6 +802,9 @@ Nothing -> return (Just AnyVersion) Just Nothing -> return (Just AnyVersion) Just (Just (Left (ThisVersionS,v))) -> return (Just (ThisVersion v)) +#if MIN_VERSION_Cabal(1,8,0) + Just (Just (Left (WildcardVersionS,v))) -> return (Just (WildcardVersion v)) +#endif Just (Just (Left (LaterVersionS,v))) -> return (Just (LaterVersion v)) Just (Just (Left (EarlierVersionS,v))) -> return (Just (EarlierVersion v)) @@ -807,13 +816,18 @@ -> return (Just (IntersectVersionRanges v1 v2)) return (wid,vrinj,vrext) where +#if MIN_VERSION_Cabal(1,8,0) + v1 = [ThisVersionS,WildcardVersionS,LaterVersionS,ThisOrLaterVersionS,EarlierVersionS,ThisOrEarlierVersionS] +#else v1 = [ThisVersionS,LaterVersionS,ThisOrLaterVersionS,EarlierVersionS,ThisOrEarlierVersionS] +#endif v2 = [UnionVersionRangesS,IntersectVersionRangesS] -data Version1 = ThisVersionS | LaterVersionS | ThisOrLaterVersionS | EarlierVersionS | ThisOrEarlierVersionS +data Version1 = ThisVersionS | WildcardVersionS | LaterVersionS | ThisOrLaterVersionS | EarlierVersionS | ThisOrEarlierVersionS deriving (Eq) instance Show Version1 where show ThisVersionS = "This Version" + show WildcardVersionS = "Wildcard Version" show LaterVersionS = "Later Version" show ThisOrLaterVersionS = "This or later Version" show EarlierVersionS = "Earlier Version" diff --git a/src/Graphics/UI/Editor/MakeEditor.hs b/src/Graphics/UI/Editor/MakeEditor.hs --- a/src/Graphics/UI/Editor/MakeEditor.hs +++ b/src/Graphics/UI/Editor/MakeEditor.hs @@ -107,7 +107,7 @@ treeViewSetHeadersVisible listView False treeSelectionSelectPath sel [0] notebookSetCurrentPage nb 0 - sel `onSelectionChanged` (do + on sel treeSelectionSelectionChanged (do selections <- treeSelectionGetSelectedRows sel case selections of [[i]] -> notebookSetCurrentPage nb i @@ -222,7 +222,6 @@ else do triggerEvent notifier (GUIEvent { selector = ValidationError, - gtkEvent = GTK.Event True, eventText = concat (intersperse ", " errors), gtkReturn = True}) return Nothing diff --git a/src/Graphics/UI/Editor/Simple.hs b/src/Graphics/UI/Editor/Simple.hs --- a/src/Graphics/UI/Editor/Simple.hs +++ b/src/Graphics/UI/Editor/Simple.hs @@ -1,4 +1,4 @@ -{-# OPTIONS_GHC -XScopedTypeVariables #-} +{-# LANGUAGE ScopedTypeVariables #-} ----------------------------------------------------------------------------- -- -- Module : Graphics.UI.Editor.Simple @@ -36,12 +36,7 @@ , okCancelFields ) where -#if MIN_VERSION_gtk(0,10,5) -import Graphics.UI.Gtk hiding (eventKeyName, eventModifier) -#else import Graphics.UI.Gtk -#endif -import qualified Graphics.UI.Gtk as Gtk import Control.Monad import Data.IORef import Data.List @@ -52,17 +47,14 @@ --import Graphics.UI.Editor.Basics import Graphics.UI.Editor.MakeEditor import Control.Event -#if MIN_VERSION_gtk(0,10,5) -import Graphics.UI.Gtk.Gdk.Events (Event(..)) -#else -import Graphics.UI.Gtk.Gdk.Events (Event(..)) -#endif import MyMissing (trim, allOf) import qualified Graphics.UI.Gtk.Gdk.Events as Gtk (Event(..)) import Unsafe.Coerce (unsafeCoerce) import Graphics.UI.Editor.Basics (GUIEvent(..), GUIEventSelector(..), propagateAsChanged, genericGUIEvents, activateEvent, Editor) +import Control.Exception as E (catch, IOException) +import Control.Monad.IO.Class (MonadIO(..)) -- ------------------------------------------------------------ -- * Simple Editors @@ -331,9 +323,7 @@ mapM_ (activateEvent (castToWidget spin) notifier Nothing) (genericGUIEvents) activateEvent (castToWidget spin) notifier (Just (\ w h -> do - res <- afterValueSpinned (castToSpinButton w) (do - h (Gtk.Event True) - return ()) + res <- afterValueSpinned (castToSpinButton w) (h >> return ()) return (unsafeCoerce res))) MayHaveChanged containerAdd widget spin spinButtonSetValue spin (fromIntegral v) @@ -359,8 +349,8 @@ s <- ext case s of Nothing -> return Nothing - Just s -> catch (liftM Just (readIO s)) - (\e -> do + Just s -> E.catch (liftM Just (readIO s)) + (\(e :: IOException) -> do putStrLn ("Generic editor no parse for " ++ s ++ " " ++ show e) return Nothing) return (wid,ginj,gext) @@ -399,14 +389,13 @@ case core of Nothing -> do combo <- comboBoxNewText + widgetSetSizeRequest combo 200 (-1) mapM_ (\o -> comboBoxAppendText combo (showF o)) list widgetSetName combo (getParameter paraName parameters) mapM_ (activateEvent (castToWidget combo) notifier Nothing) genericGUIEvents activateEvent (castToWidget combo) notifier (Just (\ w h -> do - res <- on (castToComboBox w) changed (do - h (Gtk.Event True) - return ()) + res <- on (castToComboBox w) changed (h >> return ()) return (unsafeCoerce res))) MayHaveChanged comboBoxSetActive combo 1 containerAdd widget combo @@ -518,22 +507,26 @@ containerAdd sw listView scrolledWindowSetPolicy sw PolicyAutomatic PolicyAutomatic containerAdd widget sw +#ifdef MIN_VERSION_gtk3 + scrolledWindowSetMinContentHeight sw (snd minSize) +#endif -- update the model when the toggle buttons are activated on rendererToggle cellToggled $ \pathStr -> do let (i:_) = stringToTreePath pathStr val <- listStoreGetValue listStore i listStoreSetValue listStore i (not (fst val),snd val) - listView `onKeyPress` (\event -> do - let Key { eventKeyName = name, eventModifier = modifier, eventKeyChar = char } = event - case (name, modifier, char) of - ("Return", _, _) -> do - sel <- treeViewGetSelection listView - rows <- treeSelectionGetSelectedRows sel - mapM_ (\ (i:_) -> do - val <- listStoreGetValue listStore i - listStoreSetValue listStore i (not (fst val),snd val)) rows - return True - _ -> return False) + listView `on` keyPressEvent $ do + name <- eventKeyName + liftIO $ do + case name of + "Return" -> do + sel <- treeViewGetSelection listView + rows <- treeSelectionGetSelectedRows sel + mapM_ (\ (i:_) -> do + val <- listStoreGetValue listStore i + listStoreSetValue listStore i (not (fst val),snd val)) rows + return True + _ -> return False writeIORef coreRef (Just (listView,listStore)) Just (listView,listStore) -> do let model = map (\e -> (elem e objs,e)) list @@ -585,6 +578,9 @@ containerAdd sw listView scrolledWindowSetPolicy sw PolicyAutomatic PolicyAutomatic containerAdd widget sw +#ifdef MIN_VERSION_gtk3 + scrolledWindowSetMinContentHeight sw (snd minSize) +#endif treeSelectionUnselectAll sel let mbInd = elemIndex obj list case mbInd of @@ -687,7 +683,6 @@ entrySetText entry fn triggerEvent notifier (GUIEvent { selector = MayHaveChanged, - gtkEvent = Gtk.Event True, eventText = "", gtkReturn = True}) return (e{gtkReturn=True}) @@ -708,9 +703,7 @@ mapM_ (activateEvent (castToWidget fs) notifier Nothing) (Clicked: genericGUIEvents) activateEvent (castToWidget fs) notifier (Just (\ w h -> do - res <- onFontSet (castToFontButton w) (do - h (Gtk.Event True) - return ()) + res <- onFontSet (castToFontButton w) (h >> return ()) return (unsafeCoerce res))) MayHaveChanged containerAdd widget fs case mbValue of @@ -747,9 +740,7 @@ mapM_ (activateEvent (castToWidget cs) notifier Nothing) (Clicked: genericGUIEvents) activateEvent (castToWidget cs) notifier (Just (\ w h -> do - res <- onColorSet (castToColorButton w) (do - h (Gtk.Event True) - return ()) + res <- onColorSet (castToColorButton w) (h >> return ()) return (unsafeCoerce res))) MayHaveChanged containerAdd widget cs colorButtonSetColor cs c diff --git a/src/Graphics/UI/Frame/Panes.hs b/src/Graphics/UI/Frame/Panes.hs --- a/src/Graphics/UI/Frame/Panes.hs +++ b/src/Graphics/UI/Frame/Panes.hs @@ -207,23 +207,3 @@ signalDisconnectAll :: Connections -> IO () signalDisconnectAll = mapM_ (\ (ConnectC s) -> signalDisconnect s) - --- Necessary with pre 10.1 verion of gtk2hs - -#ifdef MIN_VERSION_gtk -#if MIN_VERSION_gtk(0,10,1) -#else -instance Eq Notebook - where (==) a b = let (GObject pa, GObject pb) = (toGObject a, toGObject b) - in pa == pb -instance Ord Notebook - where (<=) a b = let (GObject pa, GObject pb) = (toGObject a, toGObject b) - in pa <= pb -instance Eq Window - where (==) a b = let (GObject pa, GObject pb) = (toGObject a, toGObject b) - in pa == pb -instance Eq Widget - where (==) a b = let (GObject pa, GObject pb) = (toGObject a, toGObject b) - in pa == pb -#endif -#endif diff --git a/src/Graphics/UI/Frame/ViewFrame.hs b/src/Graphics/UI/Frame/ViewFrame.hs --- a/src/Graphics/UI/Frame/ViewFrame.hs +++ b/src/Graphics/UI/Frame/ViewFrame.hs @@ -1,11 +1,11 @@ -{-# OPTIONS_GHC - -XFunctionalDependencies - -XNoMonomorphismRestriction - -XFlexibleInstances - -XMultiParamTypeClasses - -XUndecidableInstances - -XDeriveDataTypeable - -XBangPatterns #-} +{-# LANGUAGE CPP #-} +{-# LANGUAGE FunctionalDependencies #-} +{-# LANGUAGE NoMonomorphismRestriction #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE UndecidableInstances #-} +{-# LANGUAGE DeriveDataTypeable #-} +{-# LANGUAGE BangPatterns #-} ----------------------------------------------------------------------------- -- -- Module : IDE.Core.ViewFrame @@ -71,6 +71,8 @@ , getUiManager , getWindows , getMainWindow +, getActiveWindow +, getActiveScreen , getLayout , getPanesSt , getPaneMapSt @@ -90,7 +92,7 @@ , initGtkRc ) where -import Graphics.UI.Gtk hiding (afterToggleOverwrite,onToggleOverwrite) +import Graphics.UI.Gtk import qualified Data.Map as Map import Data.List import Data.Maybe @@ -100,16 +102,12 @@ import Graphics.UI.Frame.Panes import Graphics.UI.Editor.Parameters import System.Glib (GObjectClass(..), isA) -#if MIN_VERSION_gtk(0,10,5) import Graphics.UI.Gtk.Layout.Notebook (gTypeNotebook) -#else -import Graphics.UI.Gtk.Types (gTypeNotebook) -#endif import System.CPUTime (getCPUTime) -#if MIN_VERSION_gtk(0,10,5) import Graphics.UI.Gtk.Gdk.EventM (Modifier(..)) -#else -import Graphics.UI.Gtk.Gdk.Enums (Modifier(..)) +#ifdef MIN_VERSION_gtk3 +import Graphics.UI.Gtk.General.CssProvider (cssProviderNew, cssProviderLoadFromString) +import Graphics.UI.Gtk.General.StyleContext (styleContextAddProvider) #endif import MyMissing import Graphics.UI.Gtk.Gdk.EventM (TimeStamp(..)) @@ -124,6 +122,7 @@ import Graphics.UI.Gtk.Gdk.Events (Event(..)) import Control.Monad.IO.Class (MonadIO(..)) import Control.Monad (when, liftM, foldM) +import Control.Applicative ((<$>)) import qualified Control.Monad.Reader as Gtk (liftIO) --import Debug.Trace (trace) @@ -138,17 +137,21 @@ initGtkRc :: IO () -#if MIN_VERSION_gtk(0,11,0) +#ifdef MIN_VERSION_gtk3 +initGtkRc = return () +#else initGtkRc = rcParseString ("style \"leksah-close-button-style\"\n" ++ "{\n" ++ + " GtkButton::default-border = 0\n" ++ + " GtkButton::default-outside-border = 0\n" ++ + " GtkButton::inner-border = 0\n" ++ " GtkWidget::focus-padding = 0\n" ++ " GtkWidget::focus-line-width = 0\n" ++ " xthickness = 0\n" ++ " ythickness = 0\n" ++ + " padding = 0\n" ++ "}\n" ++ "widget \"*.leksah-close-button\" style \"leksah-close-button-style\"") -#else -initGtkRc = return () #endif removePaneAdmin :: RecoverablePane alpha beta delta => alpha -> delta () @@ -235,16 +238,26 @@ buttonSetRelief tabButton ReliefNone buttonSetAlignment tabButton (0.0,0.0) - image <- imageNewFromStock stockClose IconSizeMenu - mbPB <- widgetRenderIcon tabButton stockClose IconSizeMenu "" - (height,width) <- case mbPB of - Nothing -> return (14,14) - Just pb -> do - h <- pixbufGetHeight pb - w <- pixbufGetWidth pb - return (h,w) - on tabButton styleSet (\style -> do - widgetSetSizeRequest tabButton (height + 2) (width + 2)) + iconTheme <- iconThemeGetDefault + mbIcon <- iconThemeLoadIcon iconTheme "window-close" 10 IconLookupUseBuiltin + image <- case mbIcon of + Just i -> imageNewFromPixbuf i + Nothing -> imageNewFromStock stockClose IconSizeMenu + +#ifdef MIN_VERSION_gtk3 + provider <- cssProviderNew + cssProviderLoadFromString provider $ + ".button {\n" ++ + "-GtkButton-default-border : 0px;\n" ++ + "-GtkButton-default-outside-border : 0px;\n" ++ + "-GtkButton-inner-border: 0px;\n" ++ + "-GtkWidget-focus-line-width : 0px;\n" ++ + "-GtkWidget-focus-padding : 0px;\n" ++ + "padding: 0px;\n" ++ + "}" + context <- widgetGetStyleContext tabButton + styleContextAddProvider context provider 600 +#endif containerSetBorderWidth tabButton 0 containerAdd tabButton image @@ -261,7 +274,7 @@ return ()) return (tabButton,labelBox) cl <- runInIO closeHandler - liftIO $ onClicked tb (cl ()) + liftIO $ on tb buttonActivated (cl ()) return lb where @@ -463,7 +476,7 @@ _ -> trace ("ViewFrame>>viewSplit': parent not a notebook2: ")return () return (nb,paneDir) handleFunc <- runInIO (handleNotebookSwitch nb) - liftIO $ afterSwitchPage nb handleFunc + liftIO $ after nb switchPage handleFunc return (Just (paneDir,dir)) case mbPD of Just (paneDir,pdir) -> do @@ -625,10 +638,14 @@ groupNameDialog :: Window -> IO (Maybe String) groupNameDialog parent = liftIO $ do dia <- dialogNew - windowSetTransientFor dia parent - windowSetTitle dia "Enter group name" - upper <- dialogGetUpper dia - lower <- dialogGetActionArea dia + set dia [ windowTransientFor := parent + , windowTitle := "Enter group name" ] +#ifdef MIN_VERSION_gtk3 + upper <- castToVBox <$> dialogGetContentArea dia +#else + upper <- castToVBox <$> dialogGetUpper dia +#endif + lower <- castToHBox <$> dialogGetActionArea dia (widget,inj,ext,_) <- buildEditor moduleFields "" (widget2,_,_,notifier) <- buildEditor okCancelFields () registerEvent notifier ButtonPressed (\e -> do @@ -680,7 +697,7 @@ liftIO $ widgetShowAll nb --widgetGrabFocus activeNotebook handleFunc <- runInIO (handleNotebookSwitch nb) - liftIO $ afterSwitchPage nb handleFunc + liftIO $ after nb switchPage handleFunc adjustLayoutForNest group panePath _ -> return () @@ -740,20 +757,20 @@ (TerminalP{detachedSize = size}) -> do window <- liftIO $ do window <- windowNew - windowSetTitle window "Leksah detached window" - widgetSetName window id + set window [ windowTitle := "Leksah detached window" + , widgetName := Just id ] case size of Just (width, height) -> do windowSetDefaultSize window width height Nothing -> do - (curWidth, curHeight) <- widgetGetSize activeNotebook + (Rectangle _ _ curWidth curHeight) <- widgetGetAllocation activeNotebook windowSetDefaultSize window curWidth curHeight containerRemove (castToContainer parent) activeNotebook containerAdd window activeNotebook widgetShowAll window return window handleFunc <- runInIO (handleReattach id window) - liftIO $ window `onDelete` handleFunc + liftIO . on window deleteEvent . liftIO $ handleFunc () windows <- getWindowsSt setWindowsSt $ windows ++ [window] adjustLayoutForDetach id panePath @@ -762,7 +779,7 @@ -handleReattach :: PaneMonad alpha => String -> Window -> Event -> alpha Bool +handleReattach :: PaneMonad alpha => String -> Window -> () -> alpha Bool handleReattach windowId window _ = do layout <- getLayout case findDetachedPath windowId layout of @@ -787,7 +804,25 @@ return False -- "now destroy the window" +getActiveWindow :: PaneMonad alpha => alpha (Maybe Window) +getActiveWindow = do + mbPanePath <- getActivePanePath + case mbPanePath of + Nothing -> return Nothing + Just panePath -> do + activeNotebook <- (getNotebook' "getActiveWindow") panePath + top <- liftIO $ widgetGetToplevel activeNotebook + if (top `isA` gTypeWindow) + then return . Just $ castToWindow top + else return Nothing +getActiveScreen :: PaneMonad alpha => alpha (Maybe Screen) +getActiveScreen = do + mbWindow <- getActiveWindow + case mbWindow of + Nothing -> return Nothing + Just window -> liftIO $ Just <$> windowGetScreen window + groupMenuLabel :: PaneMonad beta => String -> beta (Maybe Label) groupMenuLabel group = liftM Just (liftIO $ labelNew (Just group)) @@ -937,6 +972,9 @@ bringPaneToFront :: RecoverablePane alpha beta delta => alpha -> IO () bringPaneToFront pane = do let tv = getTopWidget pane + w <- widgetGetToplevel tv + visible <- w `get` widgetVisible + when visible . windowPresent $ castToWindow w setCurrentNotebookPages tv diff --git a/src/Text/PrinterParser.hs b/src/Text/PrinterParser.hs --- a/src/Text/PrinterParser.hs +++ b/src/Text/PrinterParser.hs @@ -1,4 +1,4 @@ -{-# OPTIONS_GHC -XTypeSynonymInstances -XFlexibleInstances #-} +{-# LANGUAGE TypeSynonymInstances, FlexibleInstances, ScopedTypeVariables #-} -- -- | Module for saving and restoring preferences and settings -- @@ -49,6 +49,7 @@ import Data.List (foldl') import qualified Text.ParserCombinators.Parsec as P ((), CharParser(..), parseFromFile) +import Control.Exception as E (catch, IOException) type Printer beta = beta -> PP.Doc @@ -227,12 +228,12 @@ foldl' (\ doc (FDS _ printer _) -> doc PP.$+$ printer date) PP.empty dateDesc readFields :: FilePath -> [FieldDescriptionS alpha] -> alpha -> IO alpha -readFields fn fieldDescrs defaultValue = catch (do +readFields fn fieldDescrs defaultValue = E.catch (do res <- P.parseFromFile (parseFields defaultValue fieldDescrs) fn case res of Left pe -> error $ "Error reading file " ++ show fn ++ " " ++ show pe Right r -> return r) - (\ e -> error $ "Error reading file " ++ show fn ++ " " ++ show e) + (\ (e::IOException) -> error $ "Error reading file " ++ show fn ++ " " ++ show e) parseFields :: alpha -> [FieldDescriptionS alpha] -> P.CharParser () alpha parseFields defaultValue descriptions =