From 41ffa180f0080f17ac22a1997e05589a4f78f449 Mon Sep 17 00:00:00 2001 From: Robbie Gleichman Date: Thu, 2 Jul 2020 21:02:20 -0700 Subject: [PATCH] In the GUI, Nodes are created by right clicking. Nodes can can be moved by left clicking on them. --- glance.cabal | 7 ++-- gui/Drag.hs | 105 +++++++++++++++++++++++++++++++-------------------- gui/Main.hs | 49 +----------------------- 3 files changed, 70 insertions(+), 91 deletions(-) diff --git a/glance.cabal b/glance.cabal index 61c5538..0a4c2ad 100644 --- a/glance.cabal +++ b/glance.cabal @@ -68,13 +68,12 @@ executable glance-gui -Wpartial-fields build-depends: base , gi-gtk - , gi-gtk-declarative - , gi-gtk-declarative-app-simple , gi-gdk + , haskell-gi-base + , gi-gio , text - , pipes - , pipes-extras default-language: Haskell2010 + Other-modules: Drag test-suite glance-test type: exitcode-stdio-1.0 diff --git a/gui/Drag.hs b/gui/Drag.hs index 324f806..e9e1ce9 100644 --- a/gui/Drag.hs +++ b/gui/Drag.hs @@ -1,28 +1,28 @@ {-# LANGUAGE OverloadedStrings, OverloadedLabels, FlexibleContexts #-} {-# LANGUAGE NamedFieldPuns #-} +{-# LANGUAGE PartialTypeSignatures #-} -module Main where +module Drag (mainDrag) 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 Control.Monad import Data.IORef import Data.GI.Base +import qualified GI.Gdk as Gdk import qualified GI.Gio as Gio import qualified GI.Gtk as Gtk -import qualified GI.Gdk as Gdk data AppState = AppState - { _asMoveBtn :: Bool + { _asMoveBtn :: Maybe Gtk.Button } -activateApp :: Gtk.Application -> IO () -activateApp app = do - state <- newIORef (AppState{_asMoveBtn=False}) +-- TODO Add type signature +getXandY event = + (\x y -> (x, y)) <$> get event #x <*> get event #y + +startApp :: Gtk.Application -> IO () +startApp app = do + state <- newIORef (AppState{_asMoveBtn=Nothing}) w <- new Gtk.ApplicationWindow [ #application := app , #title := "Glance" @@ -37,15 +37,15 @@ activateApp app = do [ Gdk.EventMaskPointerMotionMask , Gdk.EventMaskButtonPressMask] #add scrolledWindow layout - btn0 <- new Gtk.Button [ #label := "_Hello World!", #useUnderline := True ] + let - motionCallback btn eventMotion + motionCallback eventMotion = do - moveBtn <- _asMoveBtn <$> readIORef state - if moveBtn - then (do - x <- get eventMotion #x - y <- get eventMotion #y + mMoveBtn <- _asMoveBtn <$> readIORef state + case mMoveBtn of + Nothing -> pure () + Just btn -> (do + (x, y) <- getXandY eventMotion btnWidth <- Gtk.widgetGetAllocatedWidth btn btnHeight <- Gtk.widgetGetAllocatedHeight btn Gtk.layoutMove @@ -53,43 +53,68 @@ activateApp app = do 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) + _ <- on layout #motionNotifyEvent motionCallback let btnClicked btn = do - modifyIORef state (\s@AppState{_asMoveBtn} -> s{_asMoveBtn=not _asMoveBtn}) + modifyIORef state + (\s@AppState{_asMoveBtn} + -> case _asMoveBtn of + Nothing -> s{_asMoveBtn=Just btn} + _ -> s{_asMoveBtn=Nothing} + ) btnWidth <- Gtk.widgetGetAllocatedWidth btn btnHeight <- Gtk.widgetGetAllocatedHeight btn btnAlloc <- Gtk.widgetGetAllocation btn - x <- get btnAlloc #x - y <- get btnAlloc #y + (x, y) <- getXandY btnAlloc layoutWidth <- Gtk.getLayoutWidth layout layoutHeight <- Gtk.getLayoutHeight layout - Gtk.setLayoutWidth layout (fromIntegral (x + btnWidth)) - Gtk.setLayoutHeight layout (fromIntegral (y + btnHeight)) + Gtk.setLayoutWidth layout (max layoutWidth (fromIntegral (x + btnWidth))) + Gtk.setLayoutHeight + layout + (max layoutHeight (fromIntegral (y + btnHeight))) -- 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 - + _ <- on layout #buttonPressEvent $ \ eventButton -> + do + mouseBtn <- get eventButton #button + -- button 3 is usally right mouse button + (when (mouseBtn == 3) + (do + (x, y) <- getXandY eventButton + newBtn <- new + Gtk.Button [ #label := "_Node", #useUnderline := True ] + -- Gtk.widgetAddEvents newBtn + -- [ Gdk.EventMaskButtonPressMask] + (#show newBtn) + (btnWidth, _) <- Gtk.widgetGetPreferredWidth newBtn + (btnHeight, _) <- Gtk.widgetGetPreferredHeight newBtn + Gtk.layoutPut + layout + newBtn + ((truncate x) - (btnWidth `div` 2)) + ((truncate y) - (btnHeight `div` 2)) + _ <- on newBtn #clicked (btnClicked newBtn) + -- Uncomment to stop right clicking on buttons from + -- creating new buttons at (0, 0). But buttonPressEvent + -- and buttonReleaseEvent don't seem to be triggered by + -- the mneumonic. + -- + -- _ <- on newBtn #buttonPressEvent (\_btn -> btnClicked + -- newBtn >> pure True) + (#show newBtn) + pure ())) + pure False #showAll w pure () -main :: IO () -main = do +mainDrag :: IO () +mainDrag = do app <- new Gtk.Application [] - on app #activate $ do - activateApp app - pure () + _ <- on app #activate (startApp app) status <- Gio.applicationRun app Nothing - print status + putStrLn ("Application status is " <> show status) pure () diff --git a/gui/Main.hs b/gui/Main.hs index a568e35..246f5c4 100644 --- a/gui/Main.hs +++ b/gui/Main.hs @@ -3,52 +3,7 @@ {-# LANGUAGE OverloadedStrings #-} module Main (main) where -import Control.Monad (void) - -import qualified GI.Gtk as GTK -import qualified GI.Gdk as Gdk - -import GI.Gtk.Declarative -import GI.Gtk.Declarative.App.Simple - -data AppState = AppState - { mouseX :: Int - , mouseY :: Int - } - -data AppEvent = Closed | MouseDown (Int, Int) - -appView :: AppState -> AppView GTK.Window AppEvent -appView state = - let - label = widget GTK.Label [#label := "Glance", #xalign := (0.8)] - handleButton :: Gdk.EventMotion -> GTK.Window -> IO (Bool, AppEvent) - handleButton eventMotion _ = do - x <- Gdk.getEventMotionX eventMotion - y <- Gdk.getEventMotionY eventMotion - pure (True, MouseDown (floor x, floor y)) - paddingX = min 300 (fromIntegral (mouseX state)) - in - bin - GTK.Window - [ #title := "Glance" - , on #deleteEvent (const (True, Closed)) - , onM #motionNotifyEvent handleButton - , #widthRequest := 500 - , #heightRequest := 500 - ] - -- $ widget GTK.Label [#label := "Glance", #xalign := (0.8)] - $ container GTK.Box [] [BoxChild defaultBoxChildProperties {padding=paddingX} label] - -appUpdate :: AppState -> AppEvent -> Transition AppState AppEvent -appUpdate _ event = case event of - Closed -> Exit - MouseDown (x, y) -> Transition (AppState x y) (pure Nothing) +import Drag (mainDrag) main :: IO () -main = void $ run App - { view = appView - , update = appUpdate - , inputs = [] - , initialState = AppState 0 0 - } +main = mainDrag