mirror of
https://github.com/rgleichman/glance.git
synced 2024-09-11 15:05:41 +03:00
234 lines
7.0 KiB
Haskell
234 lines
7.0 KiB
Haskell
-- This file is formatted with Ormolu
|
|
{-# LANGUAGE BlockArguments #-}
|
|
{-# LANGUAGE FlexibleContexts #-}
|
|
{-# LANGUAGE GADTs #-}
|
|
{-# LANGUAGE MultiWayIf #-}
|
|
{-# LANGUAGE NamedFieldPuns #-}
|
|
{-# LANGUAGE OverloadedLabels #-}
|
|
{-# LANGUAGE OverloadedStrings #-}
|
|
{-# LANGUAGE PartialTypeSignatures #-}
|
|
|
|
-- | All the GTK and GDK code goes in this module.
|
|
module GtkGui (gtkMain) where
|
|
|
|
-- import qualified GI.GdkPixbuf as GP
|
|
|
|
-- import Debug.Trace (trace)
|
|
|
|
import Control.Monad.IO.Class (MonadIO)
|
|
import Data.GI.Base (AttrOp ((:=)), new)
|
|
import Data.IORef (IORef, newIORef)
|
|
import qualified Data.Map.Strict as Map
|
|
import Data.Maybe (fromJust)
|
|
import Data.Text (Text)
|
|
import Data.Time.Clock.System (getSystemTime)
|
|
import Data.Word (Word16)
|
|
import GHC.Word (Word32)
|
|
import qualified GI.GLib as GLib
|
|
import qualified GI.Gdk as Gdk
|
|
import qualified GI.Gio as Gio
|
|
import qualified GI.Gtk as Gtk
|
|
import GuiInternals
|
|
( AppState,
|
|
Inputs,
|
|
KeyEvent (..),
|
|
MouseButton (..),
|
|
backgroundPress,
|
|
emptyAppState,
|
|
emptyInputs,
|
|
keyPress,
|
|
keyRelease,
|
|
renderCairo,
|
|
scroll,
|
|
step,
|
|
updateBackground,
|
|
)
|
|
|
|
--------- Constants -------------
|
|
keyStrings :: Map.Map Text KeyEvent
|
|
keyStrings =
|
|
Map.fromList
|
|
[ ("\SUB", UndoKey), -- ctrl-z
|
|
("\a", AbortKey) -- ctrl-g
|
|
]
|
|
|
|
keyCodes :: Map.Map Word16 KeyEvent
|
|
keyCodes =
|
|
Map.fromList
|
|
[ (25, MoveUp), -- qwerty w
|
|
(38, MoveLeft), -- querty a
|
|
(39, MoveDown), -- querty s
|
|
(40, MoveRight), -- querty d
|
|
(65, MouseTranslateKey) -- spacebar
|
|
]
|
|
|
|
-- | A mapping between mouse button names and the GTK
|
|
-- mouse button numbers via Enum, so order is important!
|
|
-- mouseButtonNum :: MouseButton -> Word32
|
|
-- mouseButtonNum = fromIntegral . (+ 1) . fromEnum
|
|
|
|
-- | Convert a GDK mouse button number to a MouseButton. If the button
|
|
-- is not recognized, return UnknownMouseButton.
|
|
toMouseButton :: Word32 -> MouseButton
|
|
toMouseButton gtkMouseButton =
|
|
if enumNum < fromEnum (minBound :: MouseButton)
|
|
|| enumNum > fromEnum (maxBound :: MouseButton)
|
|
then UnknownMouseButton
|
|
else -- toEnum will cause an exception if enumNum is out bounds.
|
|
toEnum enumNum
|
|
where
|
|
enumNum = fromIntegral (gtkMouseButton - 1)
|
|
|
|
getXandY ::
|
|
MonadIO f =>
|
|
Gdk.EventButton ->
|
|
f (Double, Double)
|
|
getXandY event =
|
|
(\x y -> (x, y)) <$> Gdk.getEventButtonX event <*> Gdk.getEventButtonY event
|
|
|
|
timeoutCallback ::
|
|
IORef Inputs ->
|
|
IORef AppState ->
|
|
Gdk.Window ->
|
|
Gdk.Device ->
|
|
Gtk.DrawingArea ->
|
|
IO Bool
|
|
timeoutCallback inputsRef stateRef gdkWindow device backgroundArea = do
|
|
newTime <- getSystemTime
|
|
gdkDevicePosition <- Gdk.windowGetDevicePositionDouble gdkWindow device
|
|
let (_, mouseX, mouseY, _) = gdkDevicePosition
|
|
step
|
|
inputsRef
|
|
stateRef
|
|
newTime
|
|
(mouseX, mouseY)
|
|
(Gtk.widgetQueueDraw backgroundArea)
|
|
pure Gdk.EVENT_STOP
|
|
|
|
backgroundPressCallback ::
|
|
IORef Inputs ->
|
|
IORef AppState ->
|
|
Gdk.EventButton ->
|
|
IO Bool
|
|
backgroundPressCallback inputsRef stateRef eventButton = do
|
|
mouseButton <- toMouseButton <$> Gdk.getEventButtonButton eventButton
|
|
rawMousePosition <- getXandY eventButton
|
|
backgroundPress inputsRef stateRef mouseButton rawMousePosition
|
|
pure Gdk.EVENT_STOP
|
|
|
|
decodeKey :: Maybe Text -> Word16 -> KeyEvent
|
|
decodeKey mKeyStr keyCode =
|
|
case mKeyStr of
|
|
Nothing -> UnknownKey
|
|
Just keyStr -> case Map.lookup keyStr keyStrings of
|
|
Just e -> e
|
|
Nothing -> case Map.lookup keyCode keyCodes of
|
|
Just e -> e
|
|
Nothing -> UnknownKey
|
|
|
|
keyPressCallback :: IORef Inputs -> IORef AppState -> Gdk.EventKey -> IO Bool
|
|
keyPressCallback inputsRef stateRef eventKey = do
|
|
-- TODO May want to check that ctrl is pressed by checking that
|
|
-- getEventKeyState is ModifierTypeControlMask. May also want to use
|
|
-- Gdk.KEY_?.
|
|
--
|
|
-- The KeyString is the character that was typed. This is affected
|
|
-- by the keyboard layout.
|
|
mKey <- Gdk.getEventKeyString eventKey
|
|
-- The hardware keycode is a number corresponding to a specific
|
|
-- physical key on the keyboard, so changing the keyboard layout has
|
|
-- no affect on the keycode.
|
|
keyCode <- Gdk.getEventKeyHardwareKeycode eventKey
|
|
-- putStrLn $ "key: " <> show mKey
|
|
-- putStrLn $ "keycode: " <> show keyCode
|
|
let keyEvent = decodeKey mKey keyCode
|
|
-- print keyEvent
|
|
keyPress inputsRef stateRef keyEvent
|
|
pure Gdk.EVENT_STOP
|
|
|
|
keyReleaseCallback :: IORef Inputs -> Gdk.EventKey -> IO Bool
|
|
keyReleaseCallback inputsRef eventKey = do
|
|
-- TODO May want to check that ctrl is pressed by checking that
|
|
-- getEventKeyState is ModifierTypeControlMask. May also want to use
|
|
-- Gdk.KEY_?.
|
|
mKey <- Gdk.getEventKeyString eventKey
|
|
keyCode <- Gdk.getEventKeyHardwareKeycode eventKey
|
|
let keyEvent = decodeKey mKey keyCode
|
|
keyRelease inputsRef keyEvent
|
|
pure Gdk.EVENT_STOP
|
|
|
|
scrollCallback :: IORef Inputs -> Gdk.EventScroll -> IO Bool
|
|
scrollCallback inputsRef scrollEvent = do
|
|
-- scale in (zooming in) is negative (usually -1), scale out
|
|
-- (zooming out) is positive (usually 1)
|
|
deltaY <- Gdk.getEventScrollDeltaY scrollEvent
|
|
scroll inputsRef deltaY
|
|
pure Gdk.EVENT_STOP
|
|
|
|
startApp :: Gtk.Application -> IO ()
|
|
startApp app = do
|
|
stateRef <- newIORef emptyAppState
|
|
inputsRef <- newIORef emptyInputs
|
|
window <-
|
|
new
|
|
Gtk.ApplicationWindow
|
|
[ #application := app,
|
|
#title := "Glance",
|
|
#defaultWidth := 500,
|
|
#defaultHeight := 500,
|
|
#borderWidth := 0
|
|
]
|
|
backgroundArea <- new Gtk.DrawingArea []
|
|
Gtk.widgetAddEvents window [Gdk.EventMaskKeyPressMask]
|
|
Gtk.widgetAddEvents
|
|
backgroundArea
|
|
[ Gdk.EventMaskPointerMotionMask,
|
|
Gdk.EventMaskButtonPressMask,
|
|
Gdk.EventMaskScrollMask
|
|
]
|
|
Gtk.containerAdd window backgroundArea
|
|
|
|
-- geometry <- new Gdk.Geometry [ #minWidth := 500, #minHeight := 500]
|
|
-- screen <- get window #screen
|
|
-- rgbaVisual <- #getRgbaVisual screen
|
|
-- #setVisual window rgbaVisual
|
|
-- surfaceRef <- newIORef (Nothing)
|
|
|
|
_ <-
|
|
Gtk.onWidgetDraw
|
|
backgroundArea
|
|
( \context ->
|
|
renderCairo context (updateBackground backgroundArea inputsRef stateRef)
|
|
>> pure Gdk.EVENT_STOP
|
|
)
|
|
|
|
#showAll window
|
|
gdkWindow <- fromJust <$> Gtk.widgetGetWindow window
|
|
display <- fmap fromJust Gdk.displayGetDefault -- unsafe
|
|
seat <- Gdk.displayGetDefaultSeat display
|
|
device <- fromJust <$> Gdk.seatGetPointer seat -- unsafe
|
|
_ <-
|
|
GLib.timeoutAdd
|
|
GLib.PRIORITY_DEFAULT
|
|
2 -- milliseconds between callbacks
|
|
(timeoutCallback inputsRef stateRef gdkWindow device backgroundArea)
|
|
|
|
_ <-
|
|
Gtk.onWidgetButtonPressEvent
|
|
backgroundArea
|
|
(backgroundPressCallback inputsRef stateRef)
|
|
_ <- Gtk.onWidgetKeyPressEvent window (keyPressCallback inputsRef stateRef)
|
|
_ <- Gtk.onWidgetKeyReleaseEvent window (keyReleaseCallback inputsRef)
|
|
_ <- Gtk.onWidgetScrollEvent window (scrollCallback inputsRef)
|
|
|
|
#showAll window
|
|
pure ()
|
|
|
|
gtkMain :: IO ()
|
|
gtkMain = do
|
|
app <- new Gtk.Application []
|
|
_ <- Gio.onApplicationActivate app (startApp app)
|
|
appStatus <- Gio.applicationRun app Nothing
|
|
putStrLn ("Application status is " <> show appStatus)
|
|
pure ()
|