mirror of
https://github.com/rgleichman/glance.git
synced 2024-09-11 15:05:41 +03:00
Add Drag.hs.
This commit is contained in:
parent
9e56476112
commit
121004d73e
72
gui/Drag.hs
Normal file
72
gui/Drag.hs
Normal file
@ -0,0 +1,72 @@
|
||||
{-# LANGUAGE OverloadedStrings, OverloadedLabels #-}
|
||||
|
||||
module Main where
|
||||
|
||||
-- import Data.Int
|
||||
-- import qualified Data.Text as T
|
||||
import Data.Text ()
|
||||
-- import Debug.Trace (trace, traceIO)
|
||||
-- import System.Environment (getProgName, getArgs)
|
||||
import Data.Maybe
|
||||
|
||||
import Data.GI.Base
|
||||
import qualified GI.Gio as Gio
|
||||
import qualified GI.Gtk as Gtk
|
||||
import qualified GI.Gdk as Gdk
|
||||
|
||||
activateApp :: Gtk.Application -> IO ()
|
||||
activateApp app = do
|
||||
w <- new Gtk.ApplicationWindow
|
||||
[ #application := app
|
||||
, #title := "Glance"
|
||||
, #defaultWidth := 500
|
||||
, #defaultHeight := 200
|
||||
, #borderWidth := 0
|
||||
]
|
||||
scrolledWindow <- new Gtk.ScrolledWindow []
|
||||
#add w scrolledWindow
|
||||
layout <- new Gtk.Layout [#width := 500, #height := 200]
|
||||
--Gtk.widgetAddEvents w [Gdk.EventMaskButtonPressMask]
|
||||
|
||||
#add scrolledWindow layout
|
||||
|
||||
btn <- new Gtk.Button [ #label := "_Hello World!", #useUnderline := True ]
|
||||
|
||||
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)
|
||||
|
||||
#showAll w
|
||||
pure ()
|
||||
|
||||
main :: IO ()
|
||||
main = do
|
||||
app <- new Gtk.Application []
|
||||
on app #activate $ do
|
||||
activateApp app
|
||||
pure ()
|
||||
status <- Gio.applicationRun app Nothing
|
||||
print status
|
||||
pure ()
|
Loading…
Reference in New Issue
Block a user