diff --git a/ltk.cabal b/ltk.cabal --- a/ltk.cabal +++ b/ltk.cabal @@ -1,18 +1,18 @@ name: ltk -version: 0.8.0.8 +version: 0.10.0 cabal-version: -any build-type: Simple license: GPL license-file: LICENSE copyright: Juergen "jutaro" Nicklisch-Franken maintainer: maintainer@leksah.org -build-depends: Cabal >=1.6.0 && <1.9, base >=4.0.0.0 && <4.3, - containers >=0.2 && <0.4, filepath >=1.1.0 && <1.2, - glib >=0.10.0 && <0.12, gtk >=0.10.0 && <0.12, - mtl >=1.1.0.2 && <1.2, parsec >=2.1.0.1 && <2.2, +build-depends: Cabal >=1.6.0 && <1.11, base >=4.0.0.0 && <4.4, + containers >=0.2 && <0.5, filepath >=1.1.0 && <1.3, + glib >=0.10.0 && <0.13, gtk >=0.10.0 && <0.13, + mtl >=1.1.0.2 && <2.1, parsec >=2.1.0.1 && <2.2, pretty >=1.0.1.0 && <1.1, -- Make sure we get the Cabal compaitble with ghc and haddock - haddock <2.8, ghc <6.13 + haddock <2.10, ghc <7.3 stability: homepage: http://www.leksah.org package-url: http://code.haskell.org/ltk diff --git a/src/Control/Event.hs b/src/Control/Event.hs --- a/src/Control/Event.hs +++ b/src/Control/Event.hs @@ -17,12 +17,15 @@ , Event(..) , EventSource(..) , Handlers + +, registerEvents ) where import Data.Map (Map) import qualified Data.Map as Map import Data.Unique import Control.Monad +import Data.Maybe (catMaybes) -- | Every event needs a selector, which should identify the type of event class (Eq delta, Ord delta, Show delta) => EventSelector delta @@ -35,6 +38,10 @@ type Handlers beta gamma delta = Map delta [(Unique, beta -> gamma beta)] -- | Everything which is an event source needs this +-- alpha is the Notifier +-- beta is the event +-- gamma is the monad +-- delta is the event selector class (Monad gamma, Event beta delta) => EventSource alpha beta gamma delta | alpha -> beta, alpha -> gamma where getHandlers :: alpha -> gamma (Handlers beta gamma delta) @@ -46,6 +53,7 @@ canTriggerEvent _ _ = False -- | Returns the event, so that you may get values back from an event + -- Args: Notifier, Event triggerEvent :: alpha -> beta -> gamma beta triggerEvent o e = if canTriggerEvent o (getSelector e) @@ -57,11 +65,10 @@ Just l -> foldM (\e (_,ah) -> ah e) e (reverse l) else error $ "Can't trigger event " ++ show (getSelector e) - -- | use Left to register and Right to unregister -- returns Unique if registration was successfull, else Nothing - registerEvent :: alpha -> delta - -> Either (beta -> gamma beta) Unique -> gamma (Maybe Unique) - registerEvent o e (Left handler) = + -- Args: Notifier, EventSelector, Handler (Event -> Monad Event) + registerEvent :: alpha -> delta -> (beta -> gamma beta) -> gamma (Maybe Unique) + registerEvent o e handler = if canTriggerEvent o e then do handlerMap <- getHandlers o @@ -72,7 +79,11 @@ setHandlers o newHandlers return (Just unique) else error $ "Can't register event " ++ show e - registerEvent o e (Right unique) = + + -- | use Left to register and Right to unregister + -- Args: Notifier, EventSelector, Unique + unregisterEvent :: alpha -> delta -> Unique -> gamma () + unregisterEvent o e unique = if canTriggerEvent o e then do handlerMap <- getHandlers o @@ -81,6 +92,8 @@ Just l -> let newList = filter (\ (mu,_) -> mu /= unique) l in Map.insert e newList handlerMap setHandlers o newHandlers - return (Just unique) + return () else error $ "Can't register event " ++ show e +registerEvents :: EventSource alpha beta gamma delta => alpha -> [delta] -> (beta -> gamma beta) -> gamma [Unique] +registerEvents o l handler = liftM catMaybes (mapM (\ e -> registerEvent o e handler) l) 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,4 +1,5 @@ -{-# OPTIONS_GHC -XMultiParamTypeClasses -XScopedTypeVariables #-} +{-# OPTIONS_GHC -XMultiParamTypeClasses -XScopedTypeVariables -XFlexibleContexts -XRankNTypes + -XExistentialQuantification #-} ----------------------------------------------------------------------------- -- @@ -29,10 +30,14 @@ , GtkRegFunc , Notifier(..) , GtkHandler +, Connection(..) +, Connections , activateEvent , propagateEvent , allGUIEvents +, genericGUIEvents +, propagateAsChanged ) where import Graphics.UI.Gtk @@ -89,7 +94,7 @@ data GUIEvent = GUIEvent { selector :: GUIEventSelector , gtkEvent :: Gtk.Event -, eventPaneName :: String +, eventText :: String , gtkReturn :: Bool -- ^ True means that the event has been completely handled, -- gtk shoudn't do any further action about it (Often not -- a good idea @@ -97,18 +102,20 @@ instance Event GUIEvent GUIEventSelector where getSelector = selector -data GUIEventSelector = Clicked - | FocusOut - | FocusIn - | SelectionChanged - | ButtonRelease - | AfterKeyRelease +data GUIEventSelector = FocusOut -- ^ generic, the widget looses the focus + | FocusIn -- ^ generic, the widget gets the focus + | ButtonPressed -- ^ generic, a mouse key has been pressed and released, while the widget has the focus + | KeyPressed -- ^ generic, a keyboard key has been pressed and released, while the widget has the focus + | Clicked -- ^ button specific, the button has been pressed + | MayHaveChanged -- ^ generic, no gui event, the contents of the widget may have changed + | ValidationError -- ^ validation of a contents has failed deriving (Eq,Ord,Show,Enum,Bounded) instance EventSelector GUIEventSelector allGUIEvents :: [GUIEventSelector] allGUIEvents = allOf +genericGUIEvents = [FocusOut,FocusIn,ButtonPressed,KeyPressed] -- ------------------------------------------------------------ -- * Implementation of GUI event system @@ -122,7 +129,7 @@ -- -- | A type for a function to register a gtk event -- | -type GtkRegFunc = Widget -> GtkHandler -> IO (ConnectId Widget) +type GtkRegFunc = forall o . GObjectClass o => o -> GtkHandler -> IO (Connection) -- -- | The widgets are the real event sources. @@ -134,7 +141,7 @@ -- are propageted. -- The last map is used to unregister propagated events properly -- -type GUIEventReg = ([ConnectId Widget], +type GUIEventReg = ([Connection], ([Notifier], Map Unique [(Unique,Notifier)])) -- @@ -152,6 +159,13 @@ let noti = Noti h return noti +-- +-- | Signal handlers for the different pane types +-- +data Connection = forall alpha . GObjectClass alpha => ConnectC (ConnectId alpha) + +type Connections = [Connection] + instance EventSource Notifier GUIEvent IO GUIEventSelector where getHandlers (Noti pairRef) = do (h,_) <- readIORef pairRef @@ -165,7 +179,7 @@ canTriggerEvent _ _ = True - registerEvent o@(Noti pairRef) eventSel hand@(Left handler) = do + registerEvent o@(Noti pairRef) eventSel hand = do (handlers, ger) <- readIORef pairRef unique <- myUnique o newGer <- case Map.lookup eventSel ger of @@ -181,12 +195,13 @@ return (Map.insert eventSel (cids,(notifiers,newUm)) ger) let newHandlers = case eventSel `Map.lookup` handlers of Nothing -> Map.insert eventSel - [(unique,handler)] handlers + [(unique,hand)] handlers Just l -> Map.insert eventSel - ((unique,handler):l) handlers + ((unique,hand):l) handlers writeIORef pairRef (newHandlers,newGer) return (Just unique) - registerEvent o@(Noti pairRef) eventSel (Right unique) = do + + unregisterEvent o@(Noti pairRef) eventSel unique = do (handlers, ger) <- readIORef pairRef newGer <- case Map.lookup eventSel ger of Nothing -> return ger @@ -194,7 +209,7 @@ case unique `Map.lookup` um of Nothing -> return ger Just l -> do - mapM_ (\(u,es) -> registerEvent es eventSel (Right u)) l + mapM_ (\(u,es) -> unregisterEvent es eventSel u) l let newUm = unique `Map.delete` um return (Map.insert eventSel (cids,(notis,newUm)) ger) let newHandlers = case eventSel `Map.lookup` handlers of @@ -203,7 +218,7 @@ [] -> Map.delete eventSel handlers l -> Map.insert eventSel l handlers writeIORef pairRef (newHandlers,newGer) - return (Just unique) + return () -- -- | Propagate the event with the selector from notifier to eventSource @@ -230,7 +245,7 @@ case Map.lookup eventSel ger of Just (cids,(notifiers,um)) -> do - lu <- mapM (\es -> registerEvent es eventSel (Left hand)) + lu <- mapM (\es -> registerEvent es eventSel hand) notifiers let jl = map (first fromJust) $ filter (isJust.fst) @@ -243,7 +258,14 @@ -- | Activate the event after the event has been declared and the -- widget has been constructed -- -activateEvent :: Widget -> Notifier -> Maybe GtkRegFunc -> GUIEventSelector -> IO() + +activateEvent + :: (GObjectClass o) => + o + -> Notifier + -> Maybe (o -> GtkHandler -> IO Connection) + -> GUIEventSelector + -> IO () activateEvent widget (Noti pairRef) mbRegisterFunc eventSel = do let registerFunc = case mbRegisterFunc of Just f -> f @@ -254,9 +276,11 @@ Nothing -> return False Just [] -> return False Just handlers -> do - name <- widgetGetName widget + name <- if (widget `isA` gTypeWidget) + then widgetGetName (castToWidget widget) + else return "no widget - no name" eventList <- mapM (\f -> do - let ev = GUIEvent eventSel e name False + let ev = GUIEvent eventSel e "" False f ev) (map snd handlers) let boolList = map gtkReturn eventList @@ -273,13 +297,21 @@ -- | A convinence method for not repeating this over and over again -- getStandardRegFunction :: GUIEventSelector -> GtkRegFunc -getStandardRegFunction FocusOut = \w h -> w `onFocusOut` h -getStandardRegFunction FocusIn = \w h -> w `onFocusIn` h -getStandardRegFunction ButtonRelease = \w h -> w `onButtonRelease` h -getStandardRegFunction AfterKeyRelease = \w h -> w `afterKeyRelease` h -getStandardRegFunction Clicked = \w h -> do - res <- onClicked (castToButton w) (do - h (Gtk.Event True) - return ()) - return (unsafeCoerce res) -getStandardRegFunction SelectionChanged = error "yet not implemented" +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 _ = error "Basic>>getStandardRegFunction: no original GUI event" + +registerEvents :: EventSource alpha beta gamma delta => alpha -> [delta] -> (beta -> gamma beta) -> gamma [Maybe Unique] +registerEvents notifier selectors handler = + mapM (\ s -> registerEvent notifier s handler) selectors + +propagateAsChanged + :: (EventSource alpha GUIEvent m GUIEventSelector) => + alpha -> [GUIEventSelector] -> m () +propagateAsChanged notifier selectors = + mapM_ (\s -> registerEvent notifier s + (\ e -> triggerEvent notifier e{selector = MayHaveChanged})) selectors 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 @@ -14,12 +14,9 @@ module Graphics.UI.Editor.Composite ( maybeEditor +, disableEditor , pairEditor , tupel3Editor ---, tupel4Editor ---, tupel5Editor ---, tupel6Editor ---, tupel7Editor , splitEditor , eitherOrEditor , multisetEditor @@ -57,6 +54,8 @@ import Distribution.Package (pkgName) import Data.Version (Version(..)) import MyMissing (forceJust) +import qualified Graphics.UI.Gtk.Gdk.Events as Gtk (Event(..)) +import Unsafe.Coerce (unsafeCoerce) -- -- | An editor which composes two subeditors @@ -66,7 +65,7 @@ coreRef <- newIORef Nothing noti1 <- emptyNotifier noti2 <- emptyNotifier - mapM_ (propagateEvent notifier [noti2]) allGUIEvents + mapM_ (propagateEvent notifier [noti1,noti2]) allGUIEvents fst@(fstFrame,inj1,ext1) <- fstEd fstPara noti1 snd@(sndFrame,inj2,ext2) <- sndEd sndPara noti2 mkEditor @@ -111,7 +110,7 @@ noti1 <- emptyNotifier noti2 <- emptyNotifier noti3 <- emptyNotifier - mapM_ (propagateEvent notifier [noti2]) allGUIEvents + mapM_ (propagateEvent notifier [noti1,noti2,noti3]) (Clicked : allGUIEvents) r1@(frame1,inj1,ext1) <- (fst p1) (snd p1) noti1 r2@(frame2,inj2,ext2) <- (fst p2) (snd p2) noti2 r3@(frame3,inj3,ext3) <- (fst p3) (snd p3) noti3 @@ -152,74 +151,6 @@ parameters notifier -{-- -tupel4Editor :: (Editor alpha, Parameters) - -> (Editor beta, Parameters) - -> (Editor gamma, Parameters) - -> (Editor delta, Parameters) - -> Editor (alpha,beta,gamma,delta) -tupel4Editor p1 p2 p3 p4 parameters notifier = do - (widg,inj,ext) <- pairEditor ((tupel3Editor p1 p2 p3), parameters) p4 parameters notifier - return (widg, - (\ (a, b, c, d) -> inj ((a,b,c),d)), - (do - mb <- ext - case mb of - Nothing -> return Nothing - Just ((a,b,c),d) -> return (Just (a,b,c,d)))) - -tupel5Editor :: (Editor alpha, Parameters) - -> (Editor beta, Parameters) - -> (Editor gamma, Parameters) - -> (Editor delta, Parameters) - -> (Editor epsilon, Parameters) - -> Editor (alpha,beta,gamma,delta,epsilon) -tupel5Editor p1 p2 p3 p4 p5 parameters notifier = do - (widg,inj,ext) <- pairEditor ((tupel4Editor p1 p2 p3 p4), parameters) p5 parameters notifier - return (widg, - (\ (a, b, c, d, e) -> inj ((a,b,c,d),e)), - (do - mb <- ext - case mb of - Nothing -> return Nothing - Just ((a,b,c,d),e) -> return (Just (a,b,c,d,e)))) - -tupel6Editor :: (Editor alpha, Parameters) - -> (Editor beta, Parameters) - -> (Editor gamma, Parameters) - -> (Editor delta, Parameters) - -> (Editor epsilon, Parameters) - -> (Editor zeta, Parameters) - -> Editor (alpha,beta,gamma,delta,epsilon,zeta) -tupel6Editor p1 p2 p3 p4 p5 p6 parameters notifier = do - (widg,inj,ext) <- pairEditor ((tupel5Editor p1 p2 p3 p4 p5), parameters) p6 parameters notifier - return (widg, - (\ (a, b, c, d, e, f) -> inj ((a,b,c,d,e),f)), - (do - mb <- ext - case mb of - Nothing -> return Nothing - Just ((a,b,c,d,e),f) -> return (Just (a,b,c,d,e,f)))) - -tupel7Editor :: (Editor alpha, Parameters) - -> (Editor beta, Parameters) - -> (Editor gamma, Parameters) - -> (Editor delta, Parameters) - -> (Editor epsilon, Parameters) - -> (Editor zeta, Parameters) - -> (Editor eta, Parameters) - -> Editor (alpha,beta,gamma,delta,epsilon,zeta,eta) -tupel7Editor p1 p2 p3 p4 p5 p6 p7 parameters notifier = do - (widg,inj,ext) <- pairEditor ((tupel6Editor p1 p2 p3 p4 p5 p6), parameters) p7 parameters notifier - return (widg, - (\ (a, b, c, d, e, f, g) -> inj ((a,b,c,d,e,f),g)), - (do - mb <- ext - case mb of - Nothing -> return Nothing - Just ((a,b,c,d,e,f),g) -> return (Just (a,b,c,d,e,f,g)))) ---} - -- -- | Like a pair editor, but with a moveable split -- @@ -268,13 +199,10 @@ -- maybeEditor :: Default beta => (Editor beta, Parameters) -> Bool -> String -> Editor (Maybe beta) maybeEditor (childEdit, childParams) positive boolLabel parameters notifier = do - coreRef <- newIORef Nothing - childRef <- newIORef Nothing + coreRef <- newIORef Nothing + childRef <- newIORef Nothing notifierBool <- emptyNotifier - cNoti <- emptyNotifier - mapM_ (propagateEvent notifier [notifierBool]) [Clicked,FocusIn] - mapM_ (propagateEvent notifier [cNoti]) allGUIEvents - + cNoti <- emptyNotifier mkEditor (\widget mbVal -> do core <- readIORef coreRef @@ -292,7 +220,8 @@ notifierBool boxPackStart box boolFrame PackNatural 0 containerAdd widget box - registerEvent notifierBool Clicked (Left (onClickedHandler widget coreRef childRef cNoti)) + registerEvent notifierBool Clicked (onClickedHandler widget coreRef childRef cNoti) + propagateEvent notifier [notifierBool] MayHaveChanged case mbVal of Nothing -> inj1 (not positive) Just val -> do @@ -377,14 +306,150 @@ Nothing -> do let val = childEditor editor@(_,_,_) <- childEditor childParams cNoti + mapM_ (propagateEvent notifier [cNoti]) allGUIEvents writeIORef childRef (Just editor) return editor hasChildEditor childRef = do mb <- readIORef childRef return (isJust mb) + -- -- | An editor with a subeditor which gets active, when a checkbox is selected +-- or grayed out (if the positive Argument is False) +-- +disableEditor :: Default beta => (Editor beta, Parameters) -> Bool -> String -> Editor (Bool,beta) +disableEditor (childEdit, childParams) positive boolLabel parameters notifier = do + coreRef <- newIORef Nothing + childRef <- newIORef Nothing + notifierBool <- emptyNotifier + cNoti <- emptyNotifier + mkEditor + (\widget mbVal -> do + core <- readIORef coreRef + case core of + Nothing -> do + box <- case getParameter paraDirection parameters of + Horizontal -> do + b <- hBoxNew False 1 + return (castToBox b) + Vertical -> do + b <- vBoxNew False 1 + return (castToBox b) + be@(boolFrame,inj1,ext1) <- boolEditor + (paraName <<<- ParaName boolLabel $ emptyParams) + notifierBool + boxPackStart box boolFrame PackNatural 0 + containerAdd widget box + registerEvent notifierBool Clicked + (onClickedHandler widget coreRef childRef cNoti) + propagateEvent notifier [notifierBool] MayHaveChanged + case mbVal of + (False,val) -> do + (childWidget,inj2,ext2) <- getChildEditor childRef childEdit childParams cNoti + boxPackEnd box childWidget PackGrow 0 + widgetShowAll childWidget + inj1 ( not positive) + inj2 val + widgetSetSensitive childWidget False + (True,val) -> do + (childWidget,inj2,ext2) <- getChildEditor childRef childEdit childParams cNoti + boxPackEnd box childWidget PackGrow 0 + widgetShowAll childWidget + inj1 positive + inj2 val + widgetSetSensitive childWidget True + writeIORef coreRef (Just (be,box)) + Just (be@(boolFrame,inj1,extt),box) -> do + hasChild <- hasChildEditor childRef + case mbVal of + (False,val) -> + if hasChild + then do + (childWidget,_,_) <- getChildEditor childRef childEdit childParams cNoti + inj1 (not positive) + widgetSetSensitive childWidget False + else inj1 (not positive) + (True,val) -> + if hasChild + then do + inj1 positive + (childWidget,inj2,_) <- getChildEditor childRef childEdit childParams cNoti + inj2 val + widgetSetSensitive childWidget True + else do + inj1 positive + (childWidget,inj2,_) <- getChildEditor childRef childEdit childParams cNoti + boxPackEnd box childWidget PackGrow 0 + widgetSetSensitive childWidget True + inj2 val) + (do + core <- readIORef coreRef + case core of + Nothing -> return Nothing + Just (be@(boolFrame,inj1,ext1),_) -> do + bool <- ext1 + case bool of + Nothing -> return Nothing + Just bv | bv == positive -> do + (_,_,ext2) <- getChildEditor childRef childEdit childParams cNoti + value <- ext2 + case value of + Nothing -> return Nothing + Just value -> return (Just (True, value)) + otherwise -> do + (_,_,ext2) <- getChildEditor childRef childEdit childParams cNoti + value <- ext2 + case value of + Nothing -> return Nothing + Just value -> return (Just (False, value))) + parameters + notifier + where + onClickedHandler widget coreRef childRef cNoti event = do + core <- readIORef coreRef + case core of + Nothing -> error "Impossible" + Just (be@(boolFrame,inj1,ext1),vBox) -> do + mbBool <- ext1 + case mbBool of + Just bool -> + if bool /= positive + then do + + hasChild <- hasChildEditor childRef + when hasChild $ do + (childWidget,_,_) <- getChildEditor childRef childEdit childParams cNoti + widgetSetSensitive childWidget False + else do + hasChild <- hasChildEditor childRef + if hasChild + then do + (childWidget,_,_) <- getChildEditor childRef childEdit childParams cNoti + widgetSetSensitive childWidget True + else do + (childWidget,inj2,_) <- getChildEditor childRef childEdit childParams cNoti + boxPackEnd vBox childWidget PackNatural 0 + inj2 getDefault + widgetSetSensitive childWidget True + Nothing -> return () + return (event {gtkReturn=True}) + getChildEditor childRef childEditor childParams cNoti = do + mb <- readIORef childRef + case mb of + Just editor -> return editor + Nothing -> do + let val = childEditor + editor@(_,_,_) <- childEditor childParams cNoti + mapM_ (propagateEvent notifier [cNoti]) allGUIEvents + writeIORef childRef (Just editor) + return editor + hasChildEditor childRef = do + mb <- readIORef childRef + return (isJust mb) + +-- +-- | An editor with a subeditor which gets active, when a checkbox is selected -- or deselected (if the positive Argument is False) eitherOrEditor :: (Default alpha, Default beta) => (Editor alpha, Parameters) -> (Editor beta, Parameters) -> String -> Editor (Either alpha beta) @@ -403,7 +468,7 @@ core <- readIORef coreRef case core of Nothing -> do - registerEvent noti1 Clicked (Left (onClickedHandler widget coreRef)) + registerEvent noti1 Clicked (onClickedHandler widget coreRef) box <- case getParameter paraDirection parameters of Horizontal -> do b <- hBoxNew False 1 @@ -497,7 +562,6 @@ parameters notifier = do coreRef <- newIORef Nothing cnoti <- emptyNotifier - mapM_ (propagateEvent notifier [cnoti]) allGUIEvents mkEditor (\widget vs -> do core <- readIORef coreRef @@ -513,11 +577,22 @@ bb <- hButtonBoxNew return (castToBox b,castToButtonBox bb) (frameS,injS,extS) <- singleEditor sParams cnoti + mapM_ (propagateEvent notifier [cnoti]) allGUIEvents addButton <- buttonNewWithLabel "Add" removeButton <- buttonNewWithLabel "Remove" containerAdd buttonBox addButton containerAdd buttonBox removeButton listStore <- listStoreNew ([]:: [alpha]) + activateEvent listStore notifier + (Just (\ w h -> do + res <- after (castToTreeModel w) rowInserted (\ _ _ -> + h (Gtk.Event True) >> return ()) + return (ConnectC res))) MayHaveChanged + activateEvent listStore notifier + (Just (\ w h -> do + res <- after (castToTreeModel w) rowDeleted (\ _ -> + h (Gtk.Event True) >> return ()) + return (ConnectC res))) MayHaveChanged treeView <- treeViewNewWithModel listStore let minSize = getParameter paraMinSize parameters uncurry (widgetSetSizeRequest treeView) minSize @@ -601,7 +676,7 @@ (paraMinSize <<<- ParaMinSize (-1,-1) $ parameters) notifier where - selectionHandler :: TreeSelection -> ListStore a -> Injector a -> IO () +-- selectionHandler :: TreeSelection -> ListStore a -> Injector a -> IO () selectionHandler sel listStore inj = do ts <- treeSelectionGetSelected sel case ts of @@ -623,11 +698,11 @@ (paraShadow <<<- ParaShadow ShadowIn $ paraDirection <<<- ParaDirection Vertical $ p) -stringsEditor :: (String -> Bool) -> Editor [String] -stringsEditor validation p = +stringsEditor :: (String -> Bool) -> Bool -> Editor [String] +stringsEditor validation trimBlanks p = multisetEditor (ColumnDescr False [("",(\row -> [cellText := row]))]) - (stringEditor validation, emptyParams) + (stringEditor validation trimBlanks, emptyParams) (Just sort) (Just (==)) (paraShadow <<<- ParaShadow ShadowIn $ p) @@ -637,7 +712,7 @@ (wid,inj,ext) <- pairEditor ((eitherOrEditor (comboSelectionEditor ((sort . nub) (map (display . pkgName) packages)) id , paraName <<<- ParaName "Select" $ emptyParams) - (stringEditor (const True), paraName <<<- ParaName "Enter" $ emptyParams) + (stringEditor (const True) True, paraName <<<- ParaName "Enter" $ emptyParams) "Select from list?"), paraName <<<- ParaName "Name"$ emptyParams) (versionRangeEditor,paraName <<<- ParaName "Version" $ emptyParams) (paraDirection <<<- ParaDirection Vertical $ para) @@ -754,7 +829,7 @@ versionEditor :: Editor Version versionEditor para noti = do - (wid,inj,ext) <- stringEditor (\s -> not (null s)) para noti + (wid,inj,ext) <- stringEditor (\s -> not (null s)) True para noti let pinj v = inj (display v) let pext = do s <- ext 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 @@ -30,13 +30,15 @@ import Graphics.UI.Gtk import Control.Monad -import Data.List(unzip4) +import Data.List (intersperse, unzip4) import Control.Event import Graphics.UI.Editor.Parameters import Graphics.UI.Editor.Basics --import Graphics.UI.Frame.ViewFrame import Data.Maybe (isNothing) +import Data.IORef (newIORef) +import qualified Graphics.UI.Gtk.Gdk.Events as GTK (Event(..)) -- -- | A constructor type for a field desciption @@ -140,9 +142,9 @@ Just s -> s Nothing -> "Unnamed") descrs let packParas = map (\fd -> getParameter paraPack (parameters fd)) descrs - let newExt = (\v -> extractAndValidate v getExts fieldNames) - mapM_ (\ (w,p) -> boxPackStart hb w p 0) $ zip widgets packParas mapM_ (propagateEvent notifier notifiers) allGUIEvents + let newExt = (\v -> extractAndValidate v getExts fieldNames notifier) + mapM_ (\ (w,p) -> boxPackStart hb w p 0) $ zip widgets packParas return (castToWidget hb, newInj, newExt, notifier) @@ -170,15 +172,6 @@ case b of Just b -> return (Just (setter b a)) Nothing -> return Nothing) - registerEvent noti FocusOut (Left (\e -> do - let name = eventPaneName e - e2 <- ext - when (isNothing e2) $ do - md <- messageDialogNew Nothing [] MessageWarning ButtonsClose - $ "The field " ++ name ++ " has an invalid value " - dialogRun md - widgetDestroy md - return (e{gtkReturn=False}))) inj (getter dat) return (widget, (\a -> inj (getter a)), @@ -216,8 +209,8 @@ -- | Convenience method to validate and extract fields -- -extractAndValidate :: alpha -> [alpha -> Extractor alpha] -> [String] -> IO (Maybe alpha) -extractAndValidate val getExts fieldNames = do +extractAndValidate :: alpha -> [alpha -> Extractor alpha] -> [String] -> Notifier -> IO (Maybe alpha) +extractAndValidate val getExts fieldNames notifier = do (newVal,errors) <- foldM (\ (val,errs) (ext,fn) -> do extVal <- ext val case extVal of @@ -227,10 +220,11 @@ if null errors then return (Just newVal) else do - md <- messageDialogNew Nothing [] MessageWarning ButtonsClose - $ "The following fields have invalid values." ++ concat (reverse errors) - dialogRun md - widgetDestroy md + triggerEvent notifier (GUIEvent { + selector = ValidationError, + gtkEvent = GTK.Event True, + eventText = concat (intersperse ", " errors), + gtkReturn = True}) return Nothing extract :: alpha -> [alpha -> Extractor alpha] -> IO (Maybe alpha) 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 @@ -49,7 +49,7 @@ import System.FilePath.Posix import Graphics.UI.Editor.Parameters -import Graphics.UI.Editor.Basics +--import Graphics.UI.Editor.Basics import Graphics.UI.Editor.MakeEditor import Control.Event #if MIN_VERSION_gtk(0,10,5) @@ -57,7 +57,12 @@ #else import Graphics.UI.Gtk.Gdk.Events (Event(..)) #endif -import MyMissing (allOf) +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) -- ------------------------------------------------------------ -- * Simple Editors @@ -94,7 +99,8 @@ containerAdd widget button toggleButtonSetActive button bool mapM_ (activateEvent (castToWidget button) notifier Nothing) - [Clicked,FocusOut,FocusIn] + (Clicked: genericGUIEvents) + propagateAsChanged notifier [Clicked] writeIORef coreRef (Just button) Just button -> toggleButtonSetActive button bool) (do core <- readIORef coreRef @@ -128,10 +134,9 @@ if bool then toggleButtonSetActive radio1 True else toggleButtonSetActive radio2 True - mapM_ (activateEvent (castToWidget radio1) notifier Nothing) - [Clicked,FocusOut,FocusIn] - mapM_ (activateEvent (castToWidget radio2) notifier Nothing) - [Clicked,FocusOut,FocusIn] + mapM_ (activateEvent (castToWidget radio1) notifier Nothing) (Clicked:genericGUIEvents) + mapM_ (activateEvent (castToWidget radio2) notifier Nothing) (Clicked:genericGUIEvents) + propagateAsChanged notifier [Clicked] writeIORef coreRef (Just (radio1,radio2)) Just (radio1,radio2) -> if bool @@ -175,8 +180,8 @@ (\e -> (mapM_ (\b -> activateEvent (castToWidget b) notifier Nothing e) - buttons)) - [Clicked,FocusOut,FocusIn] + buttons)) (Clicked:genericGUIEvents) + propagateAsChanged notifier [Clicked] mapM_ (\(b,n) -> toggleButtonSetActive b (n == fromEnum enumValue)) (zip buttons [0..length buttons - 1]) writeIORef coreRef (Just buttons) @@ -198,8 +203,8 @@ -- | An Editor for nothing (which may report a click) in the form of a button -- -clickEditor :: Editor () -clickEditor parameters notifier = do +clickEditor :: Bool -> Editor () +clickEditor canDefault parameters notifier = do coreRef <- newIORef Nothing mkEditor (\widget bool -> do @@ -213,6 +218,9 @@ containerAdd widget button activateEvent (castToWidget button) notifier Nothing Clicked writeIORef coreRef (Just button) + when canDefault $ do + set button [widgetCanDefault := True] + widgetGrabDefault button Just button -> return ()) (return (Just ())) (paraName <<<- ParaName "" $ parameters) @@ -243,8 +251,8 @@ -- -- | Editor for a string in the form of a text entry -- -stringEditor :: (String -> Bool) -> Editor String -stringEditor validation parameters notifier = do +stringEditor :: (String -> Bool) -> Bool -> Editor String +stringEditor validation trimBlanks parameters notifier = do coreRef <- newIORef Nothing mkEditor (\widget string -> do @@ -253,19 +261,19 @@ Nothing -> do entry <- entryNew widgetSetName entry (getParameter paraName parameters) - mapM_ (activateEvent (castToWidget entry) notifier Nothing) - [FocusOut,FocusIn,AfterKeyRelease] + mapM_ (activateEvent (castToWidget entry) notifier Nothing) genericGUIEvents + propagateAsChanged notifier [KeyPressed] containerAdd widget entry - entrySetText entry string + entrySetText entry (if trimBlanks then trim string else string) writeIORef coreRef (Just entry) - Just entry -> entrySetText entry string) + Just entry -> entrySetText entry (if trimBlanks then trim string else string)) (do core <- readIORef coreRef case core of Nothing -> return Nothing Just entry -> do r <- entryGetText entry if validation r - then return (Just r) + then return (Just (if trimBlanks then trim r else r)) else return Nothing) parameters notifier @@ -287,8 +295,8 @@ scrolledWindowSetPolicy aScrolledWindow PolicyAutomatic PolicyAutomatic containerAdd aScrolledWindow aTextView containerAdd widget aScrolledWindow - mapM_ (activateEvent (castToWidget aTextView) notifier Nothing) - [ButtonRelease,FocusOut,FocusIn] + mapM_ (activateEvent (castToWidget aTextView) notifier Nothing) genericGUIEvents + propagateAsChanged notifier [KeyPressed] buffer <- textViewGetBuffer aTextView textBufferSetText buffer string writeIORef coreRef (Just (aScrolledWindow,aTextView)) @@ -320,8 +328,13 @@ Nothing -> do spin <- spinButtonNewWithRange min max step widgetSetName spin (getParameter paraName parameters) - mapM_ (activateEvent (castToWidget spin) notifier Nothing) - [FocusOut,FocusIn] + 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 ()) + return (unsafeCoerce res))) MayHaveChanged containerAdd widget spin spinButtonSetValue spin (fromIntegral v) writeIORef coreRef (Just spin) @@ -340,7 +353,7 @@ -- | text entry genericEditor :: (Show beta, Read beta) => Editor beta genericEditor parameters notifier = do - (wid,inj,ext) <- stringEditor (const True) parameters notifier + (wid,inj,ext) <- stringEditor (const True) True parameters notifier let ginj = inj . show let gext = do s <- ext @@ -366,8 +379,7 @@ button <- buttonNewWithLabel (getParameter paraName parameters) widgetSetName button (getParameter paraName parameters) containerAdd widget button - mapM_ (activateEvent (castToWidget button) notifier Nothing) - [Clicked,FocusIn] + mapM_ (activateEvent (castToWidget button) notifier Nothing) (Clicked:genericGUIEvents) writeIORef coreRef (Just button) Just button -> return ()) (return (Just ())) @@ -389,8 +401,13 @@ combo <- comboBoxNewText mapM_ (\o -> comboBoxAppendText combo (showF o)) list widgetSetName combo (getParameter paraName parameters) - mapM_ (activateEvent (castToWidget combo) notifier Nothing) - [FocusOut,FocusIn] + 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 ()) + return (unsafeCoerce res))) MayHaveChanged comboBoxSetActive combo 1 containerAdd widget combo let ind = elemIndex obj list @@ -428,8 +445,8 @@ listStore <- listStoreNew ([]:: [alpha]) listView <- treeViewNewWithModel listStore widgetSetName listView (getParameter paraName parameters) - mapM_ (activateEvent (castToWidget listView) notifier Nothing) - [FocusOut,FocusIn] + mapM_ (activateEvent (castToWidget listView) notifier Nothing) genericGUIEvents + propagateAsChanged notifier [KeyPressed,ButtonPressed] sel <- treeViewGetSelection listView treeSelectionSetMode sel SelectionMultiple renderer <- cellRendererTextNew @@ -475,8 +492,8 @@ listStore <- listStoreNew ([]:: [(Bool,beta)]) listView <- treeViewNewWithModel listStore widgetSetName listView (getParameter paraName parameters) - mapM_ (activateEvent (castToWidget listView) notifier Nothing) - [FocusOut,FocusIn] + mapM_ (activateEvent (castToWidget listView) notifier Nothing) genericGUIEvents + propagateAsChanged notifier [KeyPressed,ButtonPressed] sel <- treeViewGetSelection listView treeSelectionSetMode sel SelectionSingle rendererToggle <- cellRendererToggleNew @@ -546,8 +563,8 @@ listStore <- listStoreNew ([]:: [alpha]) listView <- treeViewNewWithModel listStore widgetSetName listView (getParameter paraName parameters) - mapM_ (activateEvent (castToWidget listView) notifier Nothing) - [FocusOut,FocusIn] + mapM_ (activateEvent (castToWidget listView) notifier Nothing) genericGUIEvents + propagateAsChanged notifier [KeyPressed,ButtonPressed] sel <- treeViewGetSelection listView treeSelectionSetMode sel (case getParameter paraMultiSel parameters of @@ -608,13 +625,13 @@ button <- buttonNewWithLabel buttonName widgetSetName button $ getParameter paraName parameters ++ "-button" mapM_ (activateEvent (castToWidget button) notifier Nothing) - [FocusOut,FocusIn,Clicked] + (Clicked:genericGUIEvents) entry <- entryNew widgetSetName entry $ getParameter paraName parameters ++ "-entry" -- set entry [ entryEditable := False ] - mapM_ (activateEvent (castToWidget entry) notifier Nothing) - [FocusOut,FocusIn] - registerEvent notifier Clicked (Left (buttonHandler entry)) + mapM_ (activateEvent (castToWidget entry) notifier Nothing) genericGUIEvents + registerEvent notifier Clicked (buttonHandler entry) + propagateAsChanged notifier [KeyPressed,ButtonPressed] box <- case getParameter paraDirection parameters of Horizontal -> do r <- hBoxNew False 1 @@ -668,7 +685,11 @@ -- Nothing -> fn -- Just rel -> makeRelative rel fn entrySetText entry fn --- triggerEvent notifier SelectionChanged... + triggerEvent notifier (GUIEvent { + selector = MayHaveChanged, + gtkEvent = Gtk.Event True, + eventText = "", + gtkReturn = True}) return (e{gtkReturn=True}) -- @@ -684,8 +705,13 @@ Nothing -> do fs <- fontButtonNew widgetSetName fs $ getParameter paraName parameters - mapM_ (activateEvent (castToWidget fs) notifier Nothing) - [FocusOut,FocusIn,Clicked] + 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 ()) + return (unsafeCoerce res))) MayHaveChanged containerAdd widget fs case mbValue of Nothing -> return True @@ -718,8 +744,13 @@ Nothing -> do cs <- colorButtonNew widgetSetName cs $ getParameter paraName parameters - mapM_ (activateEvent (castToWidget cs) notifier Nothing) - [FocusOut,FocusIn,Clicked] + 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 ()) + return (unsafeCoerce res))) MayHaveChanged containerAdd widget cs colorButtonSetColor cs c writeIORef coreRef (Just cs) @@ -748,9 +779,9 @@ button <- buttonNewWithLabel (getParameter paraName parameters) widgetSetName button $ getParameter paraName parameters containerAdd widget button - mapM_ (activateEvent (castToWidget button) notifier Nothing) - [FocusOut,FocusIn,Clicked] - registerEvent notifier Clicked (Left (buttonHandler coreRef)) + mapM_ (activateEvent (castToWidget button) notifier Nothing) (Clicked:genericGUIEvents) + registerEvent notifier Clicked (buttonHandler coreRef) + propagateAsChanged notifier [KeyPressed,ButtonPressed,Clicked] writeIORef coreRef (Just (button,val)) Just (button, oldval) -> writeIORef coreRef (Just (button, val))) (do core <- readIORef coreRef @@ -775,17 +806,17 @@ okCancelFields :: FieldDescription () okCancelFields = HFD emptyParams [ mkField - (paraStockId <<<- ParaStockId stockOk - $ paraName <<<- ParaName "Ok" - $ emptyParams) - (const ()) - (\ a b -> b) - clickEditor - , mkField (paraStockId <<<- ParaStockId stockCancel $ paraName <<<- ParaName "Cancel" $ emptyParams) (const ()) (\ _ b -> b) - clickEditor] + (clickEditor False) + , mkField + (paraStockId <<<- ParaStockId stockOk + $ paraName <<<- ParaName "Ok" + $ emptyParams) + (const ()) + (\ a b -> b) + (clickEditor True)] 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 @@ -44,6 +44,8 @@ import qualified Data.Map as Map import Data.Typeable import Control.Monad.Trans +import Graphics.UI.Editor.Basics + (Connection(..), Connection, Connections) -- --------------------------------------------------------------------- -- Panes and pane layout @@ -201,13 +203,6 @@ instance Show Notebook where show _ = "a Notebook" - --- --- | Signal handlers for the different pane types --- -data Connection = forall alpha . GObjectClass alpha => ConnectC (ConnectId alpha) - -type Connections = [Connection] signalDisconnectAll :: Connections -> IO () signalDisconnectAll = mapM_ (\ (ConnectC s) -> signalDisconnect s) 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 @@ -118,7 +118,7 @@ import Graphics.UI.Editor.Simple (stringEditor, okCancelFields) import Control.Event (registerEvent) import Graphics.UI.Editor.Basics - (eventPaneName, GUIEventSelector(..)) + (eventText, GUIEventSelector(..)) import qualified Data.Set as Set (unions, member) import Data.Set (Set(..)) import Graphics.UI.Gtk.Gdk.Events (Event(..)) @@ -133,9 +133,10 @@ Nothing -> s Just s' -> s' + initGtkRc :: IO () -initGtkRc = return () -{-- rcParseString ("style \"leksah-close-button-style\"\n" ++ +#if MIN_VERSION_gtk(0,11,0) +initGtkRc = rcParseString ("style \"leksah-close-button-style\"\n" ++ "{\n" ++ " GtkWidget::focus-padding = 0\n" ++ " GtkWidget::focus-line-width = 0\n" ++ @@ -143,7 +144,9 @@ " ythickness = 0\n" ++ "}\n" ++ "widget \"*.leksah-close-button\" style \"leksah-close-button-style\"") ---} +#else +initGtkRc = return () +#endif removePaneAdmin :: RecoverablePane alpha beta delta => alpha -> delta () removePaneAdmin pane = do @@ -625,11 +628,11 @@ lower <- dialogGetActionArea dia (widget,inj,ext,_) <- buildEditor moduleFields "" (widget2,_,_,notifier) <- buildEditor okCancelFields () - registerEvent notifier Clicked (Left (\e -> do - case eventPaneName e of + registerEvent notifier ButtonPressed (\e -> do + case eventText e of "Ok" -> dialogResponse dia ResponseOk _ -> dialogResponse dia ResponseCancel - return e)) + return e) boxPackStart upper widget PackGrow 7 boxPackStart lower widget2 PackNatural 7 widgetShowAll dia @@ -647,7 +650,7 @@ $ emptyParams) id (\ a b -> a) - (stringEditor (\s -> True))] + (stringEditor (const True) True)] viewNest :: PaneMonad alpha => String -> alpha () viewNest group = do