module Manatee.Toolkit.Gtk.Event where
import Control.Applicative hiding (empty)
import Control.Monad.Trans
import Data.List
import Data.Map (Map)
import Data.Maybe
import Data.Text.Lazy (Text, pack, singleton, empty, append, snoc)
import Graphics.UI.Gtk
import qualified Data.Map as M
import qualified Data.Text.Lazy as DTL
eventKeystoke :: EventM EKey Text
eventKeystoke = do
keyModifier <- eventModifier
keyName <- eventKeyName'
case M.lookup keyName eventModifierMap of
Just m -> do
let modifierList = (:) m keyModifier
return $ eventModifierAliasList modifierList
Nothing -> do
removeShift <- isUnicodeKey
let modifierList = (if removeShift
then filter (/= Shift)
else id) keyModifier
shortName <- eventKeyName_
return $ eventModifierAliasList modifierList `append` shortName
eventKeyChar :: EventM EKey (Maybe Char)
eventKeyChar = keyToChar <$> eventKeyVal
eventKeyName' :: EventM EKey Text
eventKeyName' = fmap (pack . eventKeyNameAlias) eventKeyName
eventKeyName_ :: EventM EKey Text
eventKeyName_ = do
keyChar <- eventKeyChar
case keyChar of
Just c -> return $ singleton c
Nothing -> eventKeyName'
eventModifierAlias :: Modifier -> Text
eventModifierAlias = singleton . aliasMatch
where
aliasMatch Control = 'C'
aliasMatch Shift = 'S'
aliasMatch Alt = 'M'
aliasMatch Meta = 'M'
aliasMatch Super = 'P'
eventKeyNameAlias :: String -> String
eventKeyNameAlias "Page_Down" = "PageDown"
eventKeyNameAlias "Page_Up" = "PageUp"
eventKeyNameAlias key = key
eventModifierAliasList :: [Modifier] -> Text
eventModifierAliasList [] = empty
eventModifierAliasList list = DTL.concat $ map (`snoc` '-') (nub $ sort $ map eventModifierAlias list)
eventModifierMap :: Map Text Modifier
eventModifierMap =
M.fromList
[("Control_L", Control)
,("Control_R", Control)
,("Shift_L", Shift)
,("Shift_R", Shift)
,("Alt_L", Alt)
,("Alt_R", Alt)
,("Meta_L", Alt)
,("Meta_R", Alt)
,("Super_L", Super)
,("Super_R", Super)]
isUnicodeKey :: EventM EKey Bool
isUnicodeKey = isJust <$> eventKeyChar
eventWindowSize :: EventM EExpose (Double, Double)
eventWindowSize = do
dr <- eventWindow
(w,h) <- liftIO $ drawableGetSize dr
return $ if w * h > 1
then (fromIntegral w, fromIntegral h)
else (1,1)