module Graphics.UI.Editor.Basics (
Getter
, Setter
, Injector
, Extractor
, Applicator
, Editor
, emptyNotifier
, GUIEvent(..)
, GUIEventSelector(..)
, GtkRegFunc
, Notifier(..)
, GtkHandler
, Connection(..)
, Connections
, activateEvent
, propagateEvent
, allGUIEvents
, genericGUIEvents
, propagateAsChanged
) where
import Prelude
import Text.Show
import Graphics.UI.Gtk
import Data.Unique
import Data.IORef
import Data.Text (Text)
import Control.Monad
import Control.Monad.Trans (liftIO)
import Graphics.UI.Editor.Parameters
import Control.Event
import Data.Map (Map(..))
import qualified Data.Map as Map (delete,insert,lookup,empty)
import Data.Maybe (fromMaybe, isJust, fromJust)
import Unsafe.Coerce (unsafeCoerce)
import Control.Arrow (first)
import MyMissing (allOf)
import qualified Data.Text as T (pack)
fromString = Just . T.pack
ifThenElse True t _ = t
ifThenElse _ _ f = f
type Getter alpha beta = alpha -> beta
type Setter alpha beta = beta -> alpha -> alpha
type Injector beta = beta -> IO ()
type Extractor beta = IO (Maybe beta)
type Applicator beta gamma = beta -> gamma ()
type Editor alpha = Parameters -> Notifier
-> IO(Widget, Injector alpha , Extractor alpha)
data GUIEvent = GUIEvent {
selector :: GUIEventSelector
, eventText :: Text
, gtkReturn :: Bool
}
instance Event GUIEvent GUIEventSelector where
getSelector = selector
data GUIEventSelector = FocusOut
| FocusIn
| ButtonPressed
| KeyPressed
| Clicked
| MayHaveChanged
| ValidationError
deriving (Eq,Ord,Show,Enum,Bounded)
instance EventSelector GUIEventSelector
allGUIEvents :: [GUIEventSelector]
allGUIEvents = allOf
genericGUIEvents = [FocusOut,FocusIn,ButtonPressed,KeyPressed]
type GtkHandler = IO Bool
type GtkRegFunc = forall o . GObjectClass o => o -> GtkHandler -> IO Connection
type GUIEventReg = ([Connection],
([Notifier], Map Unique [(Unique,Notifier)]))
newtype Notifier = Noti (IORef (Handlers GUIEvent IO GUIEventSelector,
Map GUIEventSelector GUIEventReg))
emptyNotifier :: IO Notifier
emptyNotifier = do
h <- newIORef (Map.empty,Map.empty)
let noti = Noti h
return noti
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
return h
setHandlers (Noti pairRef) h = do
(_,r) <- readIORef pairRef
writeIORef pairRef (h,r)
myUnique _ = newUnique
canTriggerEvent _ _ = True
registerEvent o@(Noti pairRef) eventSel hand = do
(handlers, ger) <- readIORef pairRef
unique <- myUnique o
newGer <- case Map.lookup eventSel ger of
Nothing -> return ger
Just (_,([],um)) -> return ger
Just (cids,(notifiers,um)) -> do
lu <- mapM (\es -> registerEvent es eventSel hand)
notifiers
let jl = map (first fromJust)
$ filter (isJust.fst)
$ zip lu notifiers
let newUm = Map.insert unique jl um
return (Map.insert eventSel (cids,(notifiers,newUm)) ger)
let newHandlers = case eventSel `Map.lookup` handlers of
Nothing -> Map.insert eventSel
[(unique,hand)] handlers
Just l -> Map.insert eventSel
((unique,hand):l) handlers
writeIORef pairRef (newHandlers,newGer)
return (Just unique)
unregisterEvent o@(Noti pairRef) eventSel unique = do
(handlers, ger) <- readIORef pairRef
newGer <- case Map.lookup eventSel ger of
Nothing -> return ger
Just (cids,(notis,um)) ->
case unique `Map.lookup` um of
Nothing -> return ger
Just l -> do
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
Nothing -> handlers
Just l -> case filter (\ (mu,_) -> mu /= unique) l of
[] -> Map.delete eventSel handlers
l -> Map.insert eventSel l handlers
writeIORef pairRef (newHandlers,newGer)
return ()
propagateEvent :: Notifier -> [Notifier] -> GUIEventSelector -> IO ()
propagateEvent (Noti pairRef) eventSources eventSel = do
(handlers,ger) <- readIORef pairRef
let newGer = case Map.lookup eventSel ger of
Nothing -> Map.insert eventSel
([],(eventSources,Map.empty)) ger
Just (w,(notiList,unregMap)) -> Map.insert eventSel
(w,(eventSources ++ notiList,unregMap)) ger
newGer2 <- case eventSel `Map.lookup` handlers of
Nothing -> return newGer
Just hl -> foldM (repropagate eventSel) newGer hl
writeIORef pairRef (handlers,newGer)
where
repropagate :: GUIEventSelector
-> Map GUIEventSelector GUIEventReg
-> (Unique, GUIEvent -> IO GUIEvent)
-> IO (Map GUIEventSelector GUIEventReg)
repropagate eventSet ger (unique,hand) =
case Map.lookup eventSel ger of
Just (cids,(notifiers,um))
-> do
lu <- mapM (\es -> registerEvent es eventSel hand)
notifiers
let jl = map (first fromJust)
$ filter (isJust.fst)
$ zip lu notifiers
let newUm = Map.insert unique jl um
return (Map.insert eventSel (cids,(notifiers,newUm)) ger)
_ -> error "Basics>>propagateEvent: impossible case"
activateEvent
:: GObjectClass o =>
o
-> Notifier
-> Maybe (o -> IO Bool -> IO Connection)
-> GUIEventSelector
-> IO ()
activateEvent widget (Noti pairRef) mbRegisterFunc eventSel = do
let registerFunc = fromMaybe (getStandardRegFunction eventSel) mbRegisterFunc
cid <- registerFunc widget (do
(hi,_) <- readIORef pairRef
case Map.lookup eventSel hi of
Nothing -> return False
Just [] -> return False
Just handlers -> do
name <- if widget `isA` gTypeWidget
then widgetGetName (castToWidget widget)
else return "no widget - no name" :: IO Text
eventList <- mapM ((\f -> do
let ev = GUIEvent eventSel "" False
f ev) . snd) handlers
let boolList = map gtkReturn eventList
return (and boolList))
(handerls,ger) <- readIORef pairRef
let newGer = case Map.lookup eventSel ger of
Nothing -> Map.insert eventSel ([cid],([],Map.empty))
ger
Just (cids,prop) ->
Map.insert eventSel (cid:cids,prop) ger
writeIORef pairRef (handerls,newGer)
getStandardRegFunction :: GUIEventSelector -> GtkRegFunc
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 $ void $ liftIO h
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 =
mapM_ (\s -> registerEvent notifier s
(\ e -> triggerEvent notifier e{selector = MayHaveChanged}))