ltk 0.12.1.0 → 0.13.1.0
raw patch · 8 files changed
+192/−163 lines, 8 filesdep +gtk3dep ~Cabaldep ~basedep ~containers
Dependencies added: gtk3
Dependency ranges changed: Cabal, base, containers, gtk
Files
- ltk.cabal +45/−36
- src/Graphics/UI/Editor/Basics.hs +13/−16
- src/Graphics/UI/Editor/Composite.hs +22/−8
- src/Graphics/UI/Editor/MakeEditor.hs +1/−2
- src/Graphics/UI/Editor/Simple.hs +28/−37
- src/Graphics/UI/Frame/Panes.hs +0/−20
- src/Graphics/UI/Frame/ViewFrame.hs +79/−41
- src/Text/PrinterParser.hs +4/−3
ltk.cabal view
@@ -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
src/Graphics/UI/Editor/Basics.hs view
@@ -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]
src/Graphics/UI/Editor/Composite.hs view
@@ -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"
src/Graphics/UI/Editor/MakeEditor.hs view
@@ -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
src/Graphics/UI/Editor/Simple.hs view
@@ -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
src/Graphics/UI/Frame/Panes.hs view
@@ -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
src/Graphics/UI/Frame/ViewFrame.hs view
@@ -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
src/Text/PrinterParser.hs view
@@ -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 =