mirror of
https://github.com/rgleichman/glance.git
synced 2024-09-11 15:05:41 +03:00
Use motionNotifyEvent on the Layout for Drag.hs.
This commit is contained in:
parent
121004d73e
commit
bef1635245
85
gui/Drag.hs
85
gui/Drag.hs
@ -1,4 +1,5 @@
|
||||
{-# LANGUAGE OverloadedStrings, OverloadedLabels #-}
|
||||
{-# LANGUAGE OverloadedStrings, OverloadedLabels, FlexibleContexts #-}
|
||||
{-# LANGUAGE NamedFieldPuns #-}
|
||||
|
||||
module Main where
|
||||
|
||||
@ -8,55 +9,77 @@ import Data.Text ()
|
||||
-- import Debug.Trace (trace, traceIO)
|
||||
-- import System.Environment (getProgName, getArgs)
|
||||
import Data.Maybe
|
||||
import Data.IORef
|
||||
|
||||
import Data.GI.Base
|
||||
import qualified GI.Gio as Gio
|
||||
import qualified GI.Gtk as Gtk
|
||||
import qualified GI.Gdk as Gdk
|
||||
|
||||
data AppState = AppState
|
||||
{ _asMoveBtn :: Bool
|
||||
}
|
||||
|
||||
activateApp :: Gtk.Application -> IO ()
|
||||
activateApp app = do
|
||||
state <- newIORef (AppState{_asMoveBtn=False})
|
||||
w <- new Gtk.ApplicationWindow
|
||||
[ #application := app
|
||||
, #title := "Glance"
|
||||
, #defaultWidth := 500
|
||||
, #defaultHeight := 200
|
||||
, #defaultHeight := 500
|
||||
, #borderWidth := 0
|
||||
]
|
||||
scrolledWindow <- new Gtk.ScrolledWindow []
|
||||
#add w scrolledWindow
|
||||
layout <- new Gtk.Layout [#width := 500, #height := 200]
|
||||
--Gtk.widgetAddEvents w [Gdk.EventMaskButtonPressMask]
|
||||
|
||||
layout <- new Gtk.Layout []
|
||||
Gtk.widgetAddEvents layout
|
||||
[ Gdk.EventMaskPointerMotionMask
|
||||
, Gdk.EventMaskButtonPressMask]
|
||||
#add scrolledWindow layout
|
||||
btn0 <- new Gtk.Button [ #label := "_Hello World!", #useUnderline := True ]
|
||||
let
|
||||
motionCallback btn eventMotion
|
||||
= do
|
||||
moveBtn <- _asMoveBtn <$> readIORef state
|
||||
if moveBtn
|
||||
then (do
|
||||
x <- get eventMotion #x
|
||||
y <- get eventMotion #y
|
||||
btnWidth <- Gtk.widgetGetAllocatedWidth btn
|
||||
btnHeight <- Gtk.widgetGetAllocatedHeight btn
|
||||
Gtk.layoutMove
|
||||
layout
|
||||
btn
|
||||
((truncate x) - (btnWidth `div` 2))
|
||||
((truncate y) - (btnHeight `div` 2)))
|
||||
else (pure ())
|
||||
pure False
|
||||
Gtk.layoutPut layout btn0 0 0
|
||||
on layout #motionNotifyEvent (motionCallback btn0)
|
||||
|
||||
btn <- new Gtk.Button [ #label := "_Hello World!", #useUnderline := True ]
|
||||
let
|
||||
btnClicked btn
|
||||
= do
|
||||
modifyIORef state (\s@AppState{_asMoveBtn} -> s{_asMoveBtn=not _asMoveBtn})
|
||||
btnWidth <- Gtk.widgetGetAllocatedWidth btn
|
||||
btnHeight <- Gtk.widgetGetAllocatedHeight btn
|
||||
btnAlloc <- Gtk.widgetGetAllocation btn
|
||||
x <- get btnAlloc #x
|
||||
y <- get btnAlloc #y
|
||||
layoutWidth <- Gtk.getLayoutWidth layout
|
||||
layoutHeight <- Gtk.getLayoutHeight layout
|
||||
Gtk.setLayoutWidth layout (fromIntegral (x + btnWidth))
|
||||
Gtk.setLayoutHeight layout (fromIntegral (y + btnHeight))
|
||||
|
||||
Gtk.layoutPut layout btn 0 0
|
||||
|
||||
let releaseBtn eventButton = do
|
||||
btnWidth <- Gtk.widgetGetAllocatedWidth btn
|
||||
btnHeight <- Gtk.widgetGetAllocatedHeight btn
|
||||
putStrLn "button released"
|
||||
btnAlloc <- Gtk.widgetGetAllocation btn
|
||||
oldX <- Gdk.getRectangleX btnAlloc
|
||||
oldY <- Gdk.getRectangleY btnAlloc
|
||||
x <- Gdk.getEventButtonX eventButton
|
||||
y <- Gdk.getEventButtonY eventButton
|
||||
let newX = (oldX + (round x) - (btnWidth `div` 2))
|
||||
let newY = (oldY + (round y) - (btnHeight `div` 2))
|
||||
layoutWidth <- Gtk.getLayoutWidth layout
|
||||
layoutHeight <- Gtk.getLayoutHeight layout
|
||||
Gtk.setLayoutWidth layout (fromIntegral (newX + btnWidth))
|
||||
Gtk.setLayoutHeight layout (fromIntegral (newY + btnHeight))
|
||||
Gtk.layoutMove
|
||||
layout
|
||||
btn
|
||||
(oldX + (round x) - (btnWidth `div` 2))
|
||||
(oldY + (round y) - (btnHeight `div` 2))
|
||||
pure True
|
||||
|
||||
on btn #buttonReleaseEvent (releaseBtn)
|
||||
-- buttonPressEvent and buttonReleaseEvent don't seem to be triggered by the
|
||||
-- mneumonic.
|
||||
on btn0 #clicked (btnClicked btn0)
|
||||
on layout #buttonPressEvent $ \ _layout -> do
|
||||
putStrLn "layout clicked, adding btn"
|
||||
-- newBtn <- new Gtk.Button [ #label := "_New!", #useUnderline := True ]
|
||||
-- Gtk.layoutPut layout newBtn 0 0
|
||||
pure False
|
||||
|
||||
#showAll w
|
||||
pure ()
|
||||
|
Loading…
Reference in New Issue
Block a user