diff --git a/CHANGELOG.md b/CHANGELOG.md new file mode 100644 --- /dev/null +++ b/CHANGELOG.md @@ -0,0 +1,11 @@ +# Changelog for `moffy-samples-gtk3-run` + +All notable changes to this project will be documented in this file. + +The format is based on [Keep a Changelog](https://keepachangelog.com/en/1.0.0/), +and this project adheres to the +[Haskell Package Versioning Policy](https://pvp.haskell.org/). + +## Unreleased + +## 0.1.0.0 - YYYY-MM-DD diff --git a/LICENSE b/LICENSE new file mode 100644 --- /dev/null +++ b/LICENSE @@ -0,0 +1,30 @@ +Copyright Yoshikuni Jujo (c) 2023 + +All rights reserved. + +Redistribution and use in source and binary forms, with or without +modification, are permitted provided that the following conditions are met: + + * Redistributions of source code must retain the above copyright + notice, this list of conditions and the following disclaimer. + + * Redistributions in binary form must reproduce the above + copyright notice, this list of conditions and the following + disclaimer in the documentation and/or other materials provided + with the distribution. + + * Neither the name of Yoshikuni Jujo nor the names of other + contributors may be used to endorse or promote products derived + from this software without specific prior written permission. + +THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS +"AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT +LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR +A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT +OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, +SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT +LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, +DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY +THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT +(INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE +OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. diff --git a/README.md b/README.md new file mode 100644 --- /dev/null +++ b/README.md @@ -0,0 +1,1 @@ +# moffy-samples-gtk3-run diff --git a/Setup.hs b/Setup.hs new file mode 100644 --- /dev/null +++ b/Setup.hs @@ -0,0 +1,2 @@ +import Distribution.Simple +main = defaultMain diff --git a/moffy-samples-gtk3-run.cabal b/moffy-samples-gtk3-run.cabal new file mode 100644 --- /dev/null +++ b/moffy-samples-gtk3-run.cabal @@ -0,0 +1,100 @@ +cabal-version: 2.2 + +-- This file has been generated from package.yaml by hpack version 0.35.2. +-- +-- see: https://github.com/sol/hpack + +name: moffy-samples-gtk3-run +version: 0.1.0.0 +synopsis: Package to run moffy samples - GTK3 version +description: Please see the README on GitHub at +category: Control +homepage: https://github.com/YoshikuniJujo/moffy-samples-gtk3-run#readme +bug-reports: https://github.com/YoshikuniJujo/moffy-samples-gtk3-run/issues +author: Yoshikuni Jujo +maintainer: yoshikuni.jujo@gmail.com +copyright: Copyright (c) 2023 Yoshikuni Jujo +license: BSD-3-Clause +license-file: LICENSE +build-type: Simple +extra-source-files: + README.md + CHANGELOG.md + +source-repository head + type: git + location: https://github.com/YoshikuniJujo/moffy-samples-gtk3-run + +library + exposed-modules: + Control.Moffy.Samples.Boxes.Run.Gtk3 + Control.Moffy.Samples.Followbox.Run.Gtk3 + Control.Moffy.Samples.Run.Gtk3 + Stopgap.Data.Ptr + Stopgap.Graphics.UI.Gdk.Event + Stopgap.Graphics.UI.Gdk.Event.Button + Stopgap.Graphics.UI.Gdk.Event.Motion + Stopgap.Graphics.UI.Gtk + Stopgap.Graphics.UI.Gtk.Container + Stopgap.Graphics.UI.Gtk.DrawingArea + Stopgap.Graphics.UI.Gtk.Widget + Stopgap.Graphics.UI.Gtk.Window + Stopgap.System.GLib + Stopgap.System.GLib.Callback + Stopgap.System.GLib.Object + Stopgap.System.GLib.Signal + other-modules: + Paths_moffy_samples_gtk3_run + autogen-modules: + Paths_moffy_samples_gtk3_run + hs-source-dirs: + src + ghc-options: -Wall -Wcompat -Widentities -Wincomplete-record-updates -Wincomplete-uni-patterns -Wmissing-export-lists -Wmissing-home-modules -Wpartial-fields -Wredundant-constraints + pkgconfig-depends: + gtk+-3.0 + build-depends: + base >=4.7 && <5 + , c-enum + , c-struct + , containers + , moffy + , moffy-samples-events + , random + , simple-cairo + , simple-pango + , stm + , text + , time + , type-flip + , type-set + , union-color + default-language: Haskell2010 + +test-suite moffy-samples-gtk3-run-test + type: exitcode-stdio-1.0 + main-is: Spec.hs + other-modules: + Paths_moffy_samples_gtk3_run + autogen-modules: + Paths_moffy_samples_gtk3_run + hs-source-dirs: + test + ghc-options: -Wall -Wcompat -Widentities -Wincomplete-record-updates -Wincomplete-uni-patterns -Wmissing-export-lists -Wmissing-home-modules -Wpartial-fields -Wredundant-constraints -threaded -rtsopts -with-rtsopts=-N + build-depends: + base >=4.7 && <5 + , c-enum + , c-struct + , containers + , moffy + , moffy-samples-events + , moffy-samples-gtk3-run + , random + , simple-cairo + , simple-pango + , stm + , text + , time + , type-flip + , type-set + , union-color + default-language: Haskell2010 diff --git a/src/Control/Moffy/Samples/Boxes/Run/Gtk3.hs b/src/Control/Moffy/Samples/Boxes/Run/Gtk3.hs new file mode 100644 --- /dev/null +++ b/src/Control/Moffy/Samples/Boxes/Run/Gtk3.hs @@ -0,0 +1,70 @@ +{-# LANGUAGE ImportQualifiedPost #-} +{-# LANGUAGE BlockArguments, LambdaCase #-} +{-# LANGUAGE ScopedTypeVariables, TypeApplications #-} +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE TypeOperators #-} +{-# LANGUAGE FlexibleContexts #-} +{-# OPTIONS_GHC -Wall -fno-warn-tabs #-} + +module Control.Moffy.Samples.Boxes.Run.Gtk3 where + +import Prelude hiding (until) + +import Control.Monad +import Control.Concurrent +import Control.Concurrent.STM hiding (retry) +import Data.Maybe +import Data.Type.Set +import Data.Type.Flip +import Data.Time.Clock.System +import Data.Color + +import Control.Moffy +import Control.Moffy.Event.Time +import Control.Moffy.Handle +import Control.Moffy.Handle.Time +import Control.Moffy.Samples.Event.Delete +import Control.Moffy.Samples.Event.Mouse qualified as Mouse +import Control.Moffy.Samples.Event.CalcTextExtents +import Control.Moffy.Samples.Handle.TChan +import Control.Moffy.Samples.View qualified as V +import Control.Moffy.Samples.Run.TChan +import Control.Moffy.Samples.Boxes.Viewable + +import Control.Moffy.Samples.Run.Gtk3 + +runBoxes bxs = runBoxes_ $ boxesToView <$%> (emit [] >> bxs) + +runBoxes_ :: forall s es r . ( + Adjustable + (Merge es (Singleton DeleteEvent)) + (CalcTextExtents :- Mouse.Move :- Mouse.Down :- Mouse.Up :- DeltaTime :- TryWait :- DeleteEvent :- 'Nil), + Firstable es (Singleton DeleteEvent) (ISig s (es :+: Singleton DeleteEvent) V.View r) () ) => + Sig s es V.View r -> IO () +runBoxes_ b = do + er <- atomically newTChan + eo <- atomically newTChan + v <- atomically newTChan + void $ forkIO do + now <- systemToTAITime <$> getSystemTime + void . ($ (InitialMode, now)) $ interpretSt + (retrySt . ($ (0.05, ())) . popInput . handleTimeEvPlus . pushInput . const . liftHandle' . sleepIfNothing 50000 + $ handleNew @(CalcTextExtents :- Mouse.Move :- Mouse.Down :- Mouse.Up :- Singleton DeleteEvent) er eo) v do + b `until` deleteEvent :: Sig s (Merge es (Singleton DeleteEvent)) V.View (Either r (V.View, ())) + emit V.Stopped + runSingleWin er eo v + +boxesToView :: [Box] -> V.View +boxesToView = V.View . (boxToView1 <$>) + +boxToView1 :: Box -> V.View1 +boxToView1 (Box (Rect lu rd) c) = V.Box lu rd $ bColorToColor c + +bColorToColor :: BColor -> Rgb Double +bColorToColor = fromJust . \case + Red -> rgbDouble 0.8 0.1 0.05 + Green -> rgbDouble 0.2 0.6 0.1 + Blue -> rgbDouble 0.2 0.2 0.8 + Yellow -> rgbDouble 0.8 0.7 0.1 + Cyan -> rgbDouble 0.2 0.6 0.6 + Magenta -> rgbDouble 0.5 0.2 0.4 diff --git a/src/Control/Moffy/Samples/Followbox/Run/Gtk3.hs b/src/Control/Moffy/Samples/Followbox/Run/Gtk3.hs new file mode 100644 --- /dev/null +++ b/src/Control/Moffy/Samples/Followbox/Run/Gtk3.hs @@ -0,0 +1,100 @@ +{-# LANGUAGE ImportQualifiedPost #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE TypeOperators #-} +{-# LANGUAGE PatternSynonyms #-} +{-# OPTIONS_GHC -Wall -fno-warn-tabs #-} + +module Control.Moffy.Samples.Followbox.Run.Gtk3 ( + runFollowbox, runFollowbox' ) where + +import Prelude hiding (break) + +import Control.Arrow +import Control.Monad +import Control.Moffy +import Control.Moffy.Samples.Event.Delete +import Control.Moffy.Samples.Event.CalcTextExtents +import Control.Moffy.Samples.Handle.TChan +import Control.Moffy.Samples.Run.TChan +import Control.Concurrent +import Control.Concurrent.STM +import Data.Type.Set ((:-), (:+:), pattern Nil) +import Data.Type.Flip +import Data.Color +import System.Random + +import Control.Moffy.Samples.Followbox.Event +import Control.Moffy.Samples.Followbox.Handle +import Control.Moffy.Samples.Followbox.TypeSynonym + +import Control.Moffy.Samples.Run.Gtk3 + +import Control.Moffy.Samples.View + +import Control.Moffy.Samples.Followbox.ViewType qualified as T +import Control.Moffy.Samples.Viewable.Text +import Control.Moffy.Samples.Viewable.Image +import Control.Moffy.Samples.Viewable.Shape +import Data.OneOfThem + +import Data.Map qualified as M +import Control.Moffy.Samples.Event.Area qualified as A + +runFollowbox :: String -> Sig s FollowboxEv T.View () -> IO () +runFollowbox brws sig = runFollowbox_ brws Nothing . void + $ viewToView <$%> sig `break` deleteEvent `break` checkTerminate + +runFollowbox' :: String -> Sig s FollowboxEv ([(Int, Maybe Area)], T.View) () -> IO () +runFollowbox' brws sig = runFollowbox_' brws Nothing $ (second viewToView) <$%> sig + +runFollowbox_ :: String -> Maybe GithubNameToken -> Sig s FollowboxEv View () -> IO () +runFollowbox_ brws tkn sig = do + va <- atomically $ newTVar M.empty + (cer, ceo, cv) <- atomically $ + (,,) <$> newTChan <*> newTChan <*> newTChan + _ <- forkIO $ runFollowboxGen cer ceo va brws tkn cv (sig >> emit Stopped) + runSingleWin cer ceo cv + +runFollowbox_' :: String -> Maybe GithubNameToken -> Sig s FollowboxEv ([(Int, Maybe Area)], View) () -> IO () +runFollowbox_' brws tkn sig = do + va <- atomically $ newTVar M.empty + (cer, ceo, cv) <- atomically $ + (,,) <$> newTChan <*> newTChan <*> newTChan + _ <- forkIO $ runFollowboxGen' cer ceo va brws tkn cv (sig >> emit ([], Stopped)) + runSingleWin cer ceo cv + +runFollowboxGen :: + TChan (EvReqs (CalcTextExtents :- GuiEv)) -> TChan (EvOccs (CalcTextExtents :- GuiEv)) -> + TVar (M.Map Int (A.Point, A.Point)) -> String -> + Maybe GithubNameToken -> TChan x -> Sig s FollowboxEv x r -> IO r +runFollowboxGen cr c va brs mgnt c' s = do + (r, _) <- interpretSt (handleFollowbox va (cr, c) brs mgnt) c' s (initialFollowboxState $ mkStdGen 8) + pure r + +type Area = (Point, Point) + +runFollowboxGen' :: + TChan (EvReqs (CalcTextExtents :- GuiEv)) -> TChan (EvOccs (CalcTextExtents :- GuiEv)) -> + TVar (M.Map Int (A.Point, A.Point)) -> String -> + Maybe GithubNameToken -> TChan x -> + Sig s FollowboxEv ([(Int, Maybe Area)], x) r -> IO r +runFollowboxGen' cr c va brs mgnt c' s = do + (r, _) <- interpretSt' (handleFollowbox va (cr, c) brs mgnt) va c' s (initialFollowboxState $ mkStdGen 8) + pure r + +handleFollowbox :: TVar (M.Map Int (A.Point, A.Point)) -> + (TChan (EvReqs (CalcTextExtents :- GuiEv)), TChan (EvOccs (CalcTextExtents :- GuiEv))) -> Browser -> + Maybe GithubNameToken -> HandleF IO (CalcTextExtents :- GuiEv :+: FollowboxEv) +handleFollowbox va f = handleFollowboxWith (uncurry . handle) f va + +viewToView :: T.View -> View +viewToView (T.View vs) = View $ (view1ToView1 `apply`) <$> vs + +view1ToView1 :: OneOfThemFun (VText :- Line :- Image :- 'Nil) View1 +view1ToView1 = + (\(Line' (T.Color r g b) lw p0 p1) -> + VLine (RgbWord8 r g b) lw p0 p1) >-- + (\(T.Text' (T.Color r g b) fn fs p txt) -> + VText (RgbWord8 r g b) fn fs p txt) >-- SingletonFun + (\(T.Image' p (T.Png w h dt)) -> VImage p w h dt) diff --git a/src/Control/Moffy/Samples/Run/Gtk3.hs b/src/Control/Moffy/Samples/Run/Gtk3.hs new file mode 100644 --- /dev/null +++ b/src/Control/Moffy/Samples/Run/Gtk3.hs @@ -0,0 +1,218 @@ +{-# LANGUAGE ImportQualifiedPost #-} +{-# LANGUAGE LambdaCase, OverloadedStrings #-} +{-# LANGUAGE TypeOperators #-} +{-# LANGUAGE ViewPatterns #-} +{-# OPTIONS_GHC -Wall -fno-warn-tabs #-} + +module Control.Moffy.Samples.Run.Gtk3 (runSingleWin) where + +import Control.Monad +import Control.Monad.ST +import Control.Concurrent +import Control.Concurrent.STM +import Data.Type.Set +import Data.OneOrMore qualified as OOM +import Data.OneOrMoreApp +import Data.Bits +import Data.Maybe +import Data.Text qualified as T +import Data.Color +import System.Environment + +import Control.Moffy +import Control.Moffy.Samples.Event.Delete +import Control.Moffy.Samples.Event.Mouse qualified as Mouse +import Control.Moffy.Samples.Event.CalcTextExtents +import Control.Moffy.Samples.View + +import Data.CairoContext +import Graphics.Cairo.Drawing.CairoT +import Graphics.Cairo.Drawing.Paths +import Graphics.Cairo.Drawing.Transformations +import Graphics.Cairo.Surfaces.ImageSurfaces +import Graphics.Cairo.Surfaces.PngSupport + +import Graphics.Pango.Basic.LayoutObjects.PangoLayout +import Graphics.Pango.Basic.Fonts.PangoFontDescription +import Graphics.Pango.Basic.GlyphStorage +import Graphics.Pango.Rendering.Cairo + +import Stopgap.Data.Ptr +import Stopgap.System.GLib qualified as G +import Stopgap.System.GLib.Signal qualified as G.Signal +import Stopgap.Graphics.UI.Gtk qualified as Gtk +import Stopgap.Graphics.UI.Gtk.Widget qualified as Gtk.Widget +import Stopgap.Graphics.UI.Gtk.Container qualified as Gtk.Container +import Stopgap.Graphics.UI.Gtk.Window qualified as Gtk.Window +import Stopgap.Graphics.UI.Gtk.DrawingArea qualified as Gtk.DrawingArea +import Stopgap.Graphics.UI.Gdk.Event qualified as Gdk.Event +import Stopgap.Graphics.UI.Gdk.Event.Button qualified as Gdk.Event.Button +import Stopgap.Graphics.UI.Gdk.Event.Motion qualified as Gdk.Event.Motion + +type Events = CalcTextExtents :- + Mouse.Move :- Mouse.Down :- Mouse.Up :- Singleton DeleteEvent + +clicked :: TChan (EvOccs Events) -> + Gtk.DrawingArea.D -> Gdk.Event.Button.B -> ud -> IO Bool +clicked ceo _da eb _ud = do + case Gdk.Event.Button.bType eb of + Gdk.Event.ButtonPress -> atomically . writeTChan ceo + $ expand (Mouse.OccMove (mousePoint eb) >- Singleton (Mouse.OccDown $ mouseButton eb) :: EvOccs (Mouse.Move :- Singleton Mouse.Down)) + _ -> pure () + pure True + +released :: TChan (EvOccs Events) -> + Gtk.DrawingArea.D -> Gdk.Event.Button.B -> ud -> IO Bool +released ceo _da eb _ud = do + case Gdk.Event.Button.bType eb of + Gdk.Event.ButtonRelease -> atomically . writeTChan ceo + $ expand (Mouse.OccMove (mousePoint eb) >- Singleton (Mouse.OccUp $ mouseButton eb) :: EvOccs (Mouse.Move :- Singleton Mouse.Up)) + _ -> pure () + pure True + +moved :: TChan (EvOccs Events) -> + Gtk.DrawingArea.D -> Gdk.Event.Motion.M -> ud -> IO Bool +moved ceo _da em _ud = do + atomically . writeTChan ceo . expand . Singleton . Mouse.OccMove $ movePoint em + pure True + +mouseButton :: Gdk.Event.Button.B -> Mouse.Button +mouseButton eb = case Gdk.Event.Button.bButton eb of + 1 -> Mouse.ButtonPrimary + 2 -> Mouse.ButtonMiddle + 3 -> Mouse.ButtonSecondary + _ -> Mouse.ButtonMiddle + +mousePoint :: Gdk.Event.Button.B -> Point +mousePoint eb = (Gdk.Event.Button.bX eb, Gdk.Event.Button.bY eb) + +movePoint :: Gdk.Event.Motion.M -> Point +movePoint em = (Gdk.Event.Motion.mX em, Gdk.Event.Motion.mY em) + +runSingleWin :: + TChan (EvReqs Events) -> TChan (EvOccs Events) -> TChan View -> IO () +runSingleWin cer ceo cv = do + crd <- atomically $ newTVar [] + cte <- atomically newTChan + + join $ Gtk.init <$> getProgName <*> getArgs + + w <- Gtk.Window.new Gtk.Window.Toplevel + G.Signal.connect_void_void w "destroy" Gtk.mainQuit Null + + da <- Gtk.DrawingArea.new + Gtk.Container.add w da + Gtk.Widget.addEvents da $ + Gdk.Event.ButtonPressMask .|. + Gdk.Event.ButtonReleaseMask .|. + Gdk.Event.ButtonMotionMask + G.Signal.connect_self_button_ud + da "button-press-event" (clicked ceo) Null + G.Signal.connect_self_button_ud + da "button-release-event" (released ceo) Null + G.Signal.connect_self_motion_ud + da "motion-notify-event" (moved ceo) Null + G.Signal.connect_self_cairo_ud da "draw" (drawFunction crd ceo cte) Null + + Gtk.Widget.showAll w + + forkIO . forever $ atomically (readTChan cer) >>= \r -> do + case OOM.project r of + Nothing -> pure () + Just (CalcTextExtentsReq fn fs t) -> do + atomically $ writeTChan cte (fn, fs, t) + void $ G.idleAdd + (\_ -> Gtk.Widget.queueDraw da >> + pure False) + Null + + forkIO . forever $ atomically (readTChan cv) >>= \case + Stopped -> void $ G.idleAdd + (\_ -> Gtk.mainQuit >> pure False) Null + View v -> do + atomically $ writeTVar crd v + void $ G.idleAdd + (\_ -> Gtk.Widget.queueDraw da >> pure False) + Null + v -> print v + + Gtk.main + +drawFunction :: TVar [View1] -> + TChan (EvOccs Events) -> TChan (FontName, FontSize, T.Text) -> + Gtk.DrawingArea.D -> CairoT r RealWorld -> Null -> IO Bool +drawFunction crd ceo cte _ cr Null = do + atomically (tryReadTChan cte) >>= \case + Nothing -> pure () + Just (fn, fs, txt) -> occCalcTextExtents ceo cr fn fs txt + cairoSetSourceRgb cr . fromJust $ rgbDouble 0.5 0.5 0.5 + cairoPaint cr + (drawView1 cr `mapM_`) =<< atomically (readTVar crd) + pure False + +drawView1 :: CairoT r RealWorld -> View1 -> IO () +drawView1 cr (Box + (realToFrac -> l, realToFrac -> u) + (realToFrac -> r, realToFrac -> d) + (rgbRealToFrac -> clr)) = do + cairoSetSourceRgb cr clr + cairoRectangle cr l u (r - l) (d - u) + cairoFill cr +drawView1 cr (VLine (rgbRealToFrac -> clr) lw + (realToFrac -> l, realToFrac -> u) + (realToFrac -> r, realToFrac -> d)) = do + cairoSetSourceRgb cr clr + cairoSetLineWidth cr $ realToFrac lw + cairoMoveTo cr l u + cairoLineTo cr r d + cairoStroke cr +drawView1 cr (VText (rgbRealToFrac -> clr) + fn (realToFrac -> fs) (realToFrac -> x, realToFrac -> y) txt) = do + (l, d) <- (,) <$> pangoCairoCreateLayout cr <*> pangoFontDescriptionNew + d `pangoFontDescriptionSet` Family fn + d `pangoFontDescriptionSet` AbsoluteSize fs + d' <- pangoFontDescriptionFreeze d + l `pangoLayoutSet` pangoFontDescriptionToNullable (Just d') + l `pangoLayoutSet` txt + l' <- pangoLayoutFreeze l + cairoMoveTo cr x y + cairoSetSourceRgb cr clr + pangoCairoShowLayout cr l' +drawView1 cr (VImage + (realToFrac -> x, realToFrac -> y) w h dt) = do + sfc <- cairoSurfaceCreateFromPngByteString dt + w0 <- cairoImageSurfaceGetWidth sfc + h0 <- cairoImageSurfaceGetHeight sfc + cairoTranslate cr x y + cairoScale cr + (realToFrac w / fromIntegral w0) + (realToFrac h / fromIntegral h0) + cairoSetSourceSurface cr sfc 0 0 + cairoPaint cr + + cairoIdentityMatrix cr +drawView1 cr NotImplemented = putStrLn "NOT IMPLEMENTED" + +occCalcTextExtents :: + TChan (EvOccs (CalcTextExtents :- GuiEv)) -> CairoT r RealWorld -> String -> Double -> T.Text -> IO () +occCalcTextExtents co cr fn fs txt = do + (l, d) <- (,) <$> pangoCairoCreateLayout cr <*> pangoFontDescriptionNew + d `pangoFontDescriptionSet` Family fn + d `pangoFontDescriptionSet` AbsoluteSize (realToFrac fs) + d' <- pangoFontDescriptionFreeze d + l `pangoLayoutSet` pangoFontDescriptionToNullable (Just d') + l `pangoLayoutSet` txt + l' <- pangoLayoutFreeze l + let PixelExtents ie le = pangoLayoutInfo l' + atomically . writeTChan co . expand . Singleton + . OccCalcTextExtents fn fs txt + $ mkte ie le + where + mkte ie le = TextExtents (r2r ie) (r2r le) + r2r r = rct + (pangoRectanglePixelX r) (pangoRectanglePixelY r) + (pangoRectanglePixelWidth r) (pangoRectanglePixelHeight r) + rct (fromIntegral -> l) (fromIntegral -> t) + (fromIntegral -> w) (fromIntegral -> h) = Rectangle l t w h + +type GuiEv = Mouse.Move :- Mouse.Down :- Mouse.Up :- Singleton DeleteEvent diff --git a/src/Stopgap/Data/Ptr.hs b/src/Stopgap/Data/Ptr.hs new file mode 100644 --- /dev/null +++ b/src/Stopgap/Data/Ptr.hs @@ -0,0 +1,18 @@ +{-# LANGUAGE TypeFamilies #-} +{-# OPTIONS_GHC -Wall -fno-warn-tabs #-} + +module Stopgap.Data.Ptr where + +import Foreign.Ptr + +class IsPtr a where + type Tag a + toPtr :: a -> Ptr (Tag a) + fromPtr :: Ptr (Tag a) -> a + +data Null = Null + +instance IsPtr Null where + type Tag Null = Null + toPtr Null = nullPtr + fromPtr _ = Null diff --git a/src/Stopgap/Graphics/UI/Gdk/Event.hsc b/src/Stopgap/Graphics/UI/Gdk/Event.hsc new file mode 100644 --- /dev/null +++ b/src/Stopgap/Graphics/UI/Gdk/Event.hsc @@ -0,0 +1,37 @@ +{-# LANGUAGE TemplateHaskell #-} +{-# LANGUAGE PatternSynonyms #-} +{-# LANGUAGE GeneralizedNewtypeDeriving #-} +{-# OPTIONS_GHC -Wall -fno-warn-tabs #-} + +module Stopgap.Graphics.UI.Gdk.Event where + +import Foreign.Storable +import Foreign.C.Enum +import Data.Bits +import Data.Word +import Data.Int + +#include + +enum "Mask" ''#{type GdkEventMask} [''Show, ''Read, ''Eq, ''Bits] [ + ("ExposureMask", #{const GDK_EXPOSURE_MASK}), + ("PointerMotionMask", #{const GDK_POINTER_MOTION_MASK}), + ("PointerMotionHintMask", #{const GDK_POINTER_MOTION_HINT_MASK}), + ("ButtonMotionMask", #{const GDK_BUTTON_MOTION_MASK}), + ("Button1MotionMask", #{const GDK_BUTTON1_MOTION_MASK}), + ("Button2MotionMask", #{const GDK_BUTTON2_MOTION_MASK}), + ("Button3MotionMask", #{const GDK_BUTTON3_MOTION_MASK}), + ("ButtonPressMask", #{const GDK_BUTTON_PRESS_MASK}), + ("ButtonReleaseMask", #{const GDK_BUTTON_RELEASE_MASK}), + ("KeyPressMask", #{const GDK_KEY_PRESS_MASK}), + ("KeyReleaseMask", #{const GDK_KEY_RELEASE_MASK}), + ("EnterNotifyMask", #{const GDK_ENTER_NOTIFY_MASK}), + ("LeaveNotifyMask", #{const GDK_LEAVE_NOTIFY_MASK}) + ] + +enum "Type" ''#{type GdkEventType} [''Show, ''Read, ''Eq, ''Ord, ''Storable] [ + ("Delete", #{const GDK_DELETE}), + ("MotionNotify", #{const GDK_MOTION_NOTIFY}), + ("ButtonPress", #{const GDK_BUTTON_PRESS}), + ("ButtonRelease", #{const GDK_BUTTON_RELEASE}) + ] diff --git a/src/Stopgap/Graphics/UI/Gdk/Event/Button.hsc b/src/Stopgap/Graphics/UI/Gdk/Event/Button.hsc new file mode 100644 --- /dev/null +++ b/src/Stopgap/Graphics/UI/Gdk/Event/Button.hsc @@ -0,0 +1,62 @@ +{-# LANGUAGE TemplateHaskell #-} +{-# LANGUAGE TupleSections #-} +{-# LANGUAGE PatternSynonyms, ViewPatterns #-} +{-# OPTIONS_GHC -Wall -fno-warn-tabs #-} + +module Stopgap.Graphics.UI.Gdk.Event.Button where + +import Foreign.Ptr +import Foreign.Storable +import Foreign.C.Struct +import Data.Word +import Data.Int + +import Stopgap.Graphics.UI.Gdk.Event + +#include + +data GdkWindowTag +data GdkDeviceTag + +type PtrGdkWindow = Ptr GdkWindowTag +type PtrGdkDevice = Ptr GdkDeviceTag +type PtrGdouble = Ptr #{type gdouble} + +struct "B" #{size GdkEventButton} #{alignment GdkEventButton} + [ ("type", ''Type, + [| #{peek GdkEventButton, type} |], + [| #{poke GdkEventButton, type} |]), + ("window", ''PtrGdkWindow, + [| #{peek GdkEventButton, window} |], + [| #{poke GdkEventButton, window} |]), + ("send_event", ''#{type gint8}, + [| #{peek GdkEventButton, send_event} |], + [| #{poke GdkEventButton, send_event} |]), + ("time", ''#{type guint32}, + [| #{peek GdkEventButton, time} |], + [| #{poke GdkEventButton, time} |]), + ("x", ''#{type gdouble}, + [| #{peek GdkEventButton, x} |], + [| #{poke GdkEventButton, x} |]), + ("y", ''#{type gdouble}, + [| #{peek GdkEventButton, y} |], + [| #{poke GdkEventButton, y} |]), + ("axes", ''PtrGdouble, + [| #{peek GdkEventButton, axes} |], + [| #{poke GdkEventButton, axes} |]), + ("state", ''#{type GdkModifierType}, + [| #{peek GdkEventButton, state} |], + [| #{poke GdkEventButton, state} |]), + ("button", ''#{type guint}, + [| #{peek GdkEventButton, button} |], + [| #{poke GdkEventButton, button} |]), + ("device", ''PtrGdkDevice, + [| #{peek GdkEventButton, device} |], + [| #{poke GdkEventButton, device} |]), + ("x_root", ''#{type gdouble}, + [| #{peek GdkEventButton, x_root} |], + [| #{poke GdkEventButton, x_root} |]), + ("y_root", ''#{type gdouble}, + [| #{peek GdkEventButton, y_root} |], + [| #{poke GdkEventButton, y_root} |]) ] + [''Show, ''Eq, ''Ord, ''Storable] diff --git a/src/Stopgap/Graphics/UI/Gdk/Event/Motion.hsc b/src/Stopgap/Graphics/UI/Gdk/Event/Motion.hsc new file mode 100644 --- /dev/null +++ b/src/Stopgap/Graphics/UI/Gdk/Event/Motion.hsc @@ -0,0 +1,62 @@ +{-# LANGUAGE TemplateHaskell #-} +{-# LANGUAGE TupleSections #-} +{-# LANGUAGE PatternSynonyms, ViewPatterns #-} +{-# OPTIONS_GHC -Wall -fno-warn-tabs #-} + +module Stopgap.Graphics.UI.Gdk.Event.Motion where + +import Foreign.Ptr +import Foreign.Storable +import Foreign.C.Struct +import Data.Word +import Data.Int + +import Stopgap.Graphics.UI.Gdk.Event + +#include + +data GdkWindowTag +data GdkDeviceTag + +type PtrGdkWindow = Ptr GdkWindowTag +type PtrGdkDevice = Ptr GdkDeviceTag +type PtrGdouble = Ptr #{type gdouble} + +struct "M" #{size GdkEventMotion} #{alignment GdkEventMotion} + [ ("type", ''Type, + [| #{peek GdkEventMotion, type} |], + [| #{poke GdkEventMotion, type} |]), + ("window", ''PtrGdkWindow, + [| #{peek GdkEventMotion, window} |], + [| #{poke GdkEventMotion, window} |]), + ("send_event", ''#{type gint8}, + [| #{peek GdkEventMotion, send_event} |], + [| #{poke GdkEventMotion, send_event} |]), + ("time", ''#{type guint32}, + [| #{peek GdkEventMotion, time} |], + [| #{poke GdkEventMotion, time} |]), + ("x", ''#{type gdouble}, + [| #{peek GdkEventMotion, x} |], + [| #{poke GdkEventMotion, x} |]), + ("y", ''#{type gdouble}, + [| #{peek GdkEventMotion, y} |], + [| #{poke GdkEventMotion, y} |]), + ("axes", ''PtrGdouble, + [| #{peek GdkEventMotion, axes} |], + [| #{poke GdkEventMotion, axes} |]), + ("state", ''#{type GdkModifierType}, + [| #{peek GdkEventMotion, state} |], + [| #{poke GdkEventMotion, state} |]), + ("is_hint", ''#{type gint16}, + [| #{peek GdkEventMotion, is_hint} |], + [| #{poke GdkEventMotion, is_hint} |]), + ("device", ''PtrGdkDevice, + [| #{peek GdkEventMotion, device} |], + [| #{poke GdkEventMotion, device} |]), + ("x_root", ''#{type gdouble}, + [| #{peek GdkEventMotion, x_root} |], + [| #{poke GdkEventMotion, x_root} |]), + ("y_root", ''#{type gdouble}, + [| #{peek GdkEventMotion, y_root} |], + [| #{poke GdkEventMotion, y_root} |]) ] + [''Show, ''Eq, ''Ord, ''Storable] diff --git a/src/Stopgap/Graphics/UI/Gtk.hsc b/src/Stopgap/Graphics/UI/Gtk.hsc new file mode 100644 --- /dev/null +++ b/src/Stopgap/Graphics/UI/Gtk.hsc @@ -0,0 +1,39 @@ +{-# LANGUAGE BlockArguments #-} +{-# OPTIONS_GHC -Wall -fno-warn-tabs #-} + +module Stopgap.Graphics.UI.Gtk where + +import Foreign.Ptr +import Foreign.Marshal.Alloc +import Foreign.Marshal.Array +import Foreign.Storable +import Foreign.C.Types +import Foreign.C.String + +init :: String -> [String] -> IO () +init cmd as = withArgcArgv cmd as c_gtk_init + +withArgcArgv :: String -> [String] -> (Ptr CInt -> Ptr (Ptr CString) -> IO a) -> IO a +withArgcArgv cmd as f = withCStringList (cmd : as) \cas -> + withArrayLen cas \argc argv -> + alloca \pargc -> alloca \pargv -> do + poke pargc (fromIntegral argc) + poke pargv argv + f pargc pargv + +withCStringList :: [String] -> ([CString] -> IO a) -> IO a +withCStringList [] f = f [] +withCStringList (a : as) f = + withCString a \ca -> withCStringList as \cas -> f $ ca : cas + +foreign import ccall "gtk_init" c_gtk_init :: Ptr CInt -> Ptr (Ptr CString) -> IO () + +main :: IO () +main = c_gtk_main + +foreign import ccall "gtk_main" c_gtk_main :: IO () + +mainQuit :: IO () +mainQuit = c_gtk_main_quit + +foreign import ccall "gtk_main_quit" c_gtk_main_quit :: IO () diff --git a/src/Stopgap/Graphics/UI/Gtk/Container.hsc b/src/Stopgap/Graphics/UI/Gtk/Container.hsc new file mode 100644 --- /dev/null +++ b/src/Stopgap/Graphics/UI/Gtk/Container.hsc @@ -0,0 +1,19 @@ +{-# LANGUAGE ImportQualifiedPost #-} +{-# OPTIONS_GHC -Wall -fno-warn-tabs #-} + +module Stopgap.Graphics.UI.Gtk.Container where + +import Foreign.Ptr +import Stopgap.Graphics.UI.Gtk.Widget qualified as Gtk.Widget + +data CTag + +newtype C = C (Ptr CTag) deriving Show + +class Gtk.Widget.IsW c => IsC c where toC :: c -> C + +add :: (IsC c, Gtk.Widget.IsW w) => c -> w -> IO () +add c w = c_gtk_container_add (toC c) (Gtk.Widget.toW w) + +foreign import ccall "gtk_container_add" c_gtk_container_add :: + C -> Gtk.Widget.W -> IO () diff --git a/src/Stopgap/Graphics/UI/Gtk/DrawingArea.hsc b/src/Stopgap/Graphics/UI/Gtk/DrawingArea.hsc new file mode 100644 --- /dev/null +++ b/src/Stopgap/Graphics/UI/Gtk/DrawingArea.hsc @@ -0,0 +1,23 @@ +{-# LANGUAGE ImportQualifiedPost #-} +{-# LANGUAGE TypeFamilies #-} +{-# OPTIONS_GHC -Wall -fno-warn-tabs #-} + +module Stopgap.Graphics.UI.Gtk.DrawingArea where + +import Foreign.Ptr +import Stopgap.Data.Ptr +import Stopgap.System.GLib.Object qualified as G.Object +import Stopgap.Graphics.UI.Gtk.Widget qualified as Widget + +data DTag + +newtype D = D (Ptr DTag) deriving Show + +instance IsPtr D where type Tag D = DTag; toPtr (D p) = p; fromPtr = D +instance G.Object.IsO D where toO (D p) = G.Object.O $ castPtr p +instance Widget.IsW D where toW (D p) = Widget.W $ castPtr p + +new :: IO D +new = c_gtk_drawing_area_new + +foreign import ccall "gtk_drawing_area_new" c_gtk_drawing_area_new :: IO D diff --git a/src/Stopgap/Graphics/UI/Gtk/Widget.hsc b/src/Stopgap/Graphics/UI/Gtk/Widget.hsc new file mode 100644 --- /dev/null +++ b/src/Stopgap/Graphics/UI/Gtk/Widget.hsc @@ -0,0 +1,31 @@ +{-# LANGUAGE ImportQualifiedPost #-} +{-# OPTIONS_GHC -Wall -fno-warn-tabs #-} + +module Stopgap.Graphics.UI.Gtk.Widget where + +import Foreign.Ptr +import Stopgap.System.GLib.Object qualified as G.Object +import Stopgap.Graphics.UI.Gdk.Event qualified as Gdk.Event + +class G.Object.IsO w => IsW w where toW :: w -> W + +data WTag + +newtype W = W (Ptr WTag) deriving Show + +showAll :: IsW w => w -> IO () +showAll = c_gtk_widget_show_all . toW + +foreign import ccall "gtk_widget_show_all" c_gtk_widget_show_all :: W -> IO () + +addEvents :: IsW w => w -> Gdk.Event.Mask -> IO () +addEvents = c_gtk_widget_add_events . toW + +foreign import ccall "gtk_widget_add_events" c_gtk_widget_add_events :: + W -> Gdk.Event.Mask -> IO () + +queueDraw :: IsW w => w ->IO () +queueDraw = c_gtk_widget_queue_draw . toW + +foreign import ccall "gtk_widget_queue_draw" c_gtk_widget_queue_draw :: + W -> IO () diff --git a/src/Stopgap/Graphics/UI/Gtk/Window.hsc b/src/Stopgap/Graphics/UI/Gtk/Window.hsc new file mode 100644 --- /dev/null +++ b/src/Stopgap/Graphics/UI/Gtk/Window.hsc @@ -0,0 +1,35 @@ +{-# LANGUAGE ImportQualifiedPost #-} +{-# LANGUAGE TemplateHaskell #-} +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE PatternSynonyms #-} +{-# OPTIONS_GHC -Wall -fno-warn-tabs #-} + +module Stopgap.Graphics.UI.Gtk.Window where + +import Foreign.Ptr +import Foreign.C.Enum +import Data.Word +import Stopgap.Data.Ptr +import Stopgap.System.GLib.Object qualified as G.Object +import Stopgap.Graphics.UI.Gtk.Widget qualified as Widget +import Stopgap.Graphics.UI.Gtk.Container qualified as Container + +#include + +enum "Type" ''#{type GtkWindowType} [''Show, ''Read, ''Eq] [ + ("Toplevel", #{const GTK_WINDOW_TOPLEVEL}), + ("Popup", #{const GTK_WINDOW_POPUP}) ] + +data WTag + +newtype W = W (Ptr WTag) deriving Show + +instance IsPtr W where type Tag W = WTag; toPtr (W p) = p; fromPtr = W +instance G.Object.IsO W where toO (W p) = G.Object.O $ castPtr p +instance Widget.IsW W where toW (W p) = Widget.W $ castPtr p +instance Container.IsC W where toC (W p) = Container.C $ castPtr p + +new :: Type -> IO W +new = c_gtk_window_new + +foreign import ccall "gtk_window_new" c_gtk_window_new :: Type -> IO W diff --git a/src/Stopgap/System/GLib.hsc b/src/Stopgap/System/GLib.hsc new file mode 100644 --- /dev/null +++ b/src/Stopgap/System/GLib.hsc @@ -0,0 +1,30 @@ +{-# LANGUAGE LambdaCase #-} +{-# OPTIONS_GHC -Wall -fno-warn-tabs #-} + +module Stopgap.System.GLib where + +import Foreign.Ptr +import Data.Word +import Data.Int +import Stopgap.Data.Ptr + +#include + +idleAdd :: IsPtr ud => (ud -> IO Bool) -> ud -> IO #{type guint} +idleAdd h ud = wrapHandler h >>= \ch -> c_g_idle_add ch $ toPtr ud + +foreign import ccall "g_idle_add" c_g_idle_add :: + FunPtr (Ptr ud -> IO #{type gboolean}) -> Ptr ud -> IO #{type guint} + +wrapHandler :: IsPtr ud => + (ud -> IO Bool) -> IO (FunPtr (Ptr (Tag ud) -> IO #{type gboolean})) +wrapHandler h = do + let g pud = boolToGboolean <$> h (fromPtr pud) + c_wrap_handler g + +boolToGboolean :: Bool -> #{type gboolean} +boolToGboolean = \case False -> #{const FALSE}; True -> #{const TRUE} + +foreign import ccall "wrapper" c_wrap_handler :: + (Ptr ud -> IO #{type gboolean}) -> + IO (FunPtr (Ptr ud -> IO #{type gboolean})) diff --git a/src/Stopgap/System/GLib/Callback.hsc b/src/Stopgap/System/GLib/Callback.hsc new file mode 100644 --- /dev/null +++ b/src/Stopgap/System/GLib/Callback.hsc @@ -0,0 +1,98 @@ +{-# LANGUAGE ImportQualifiedPost #-} +{-# LANGUAGE CApiFFI #-} +{-# LANGUAGE LambdaCase #-} +{-# OPTIONS_GHC -Wall -fno-warn-tabs #-} + +module Stopgap.System.GLib.Callback where + +import Foreign.Ptr +import Foreign.Concurrent +import Foreign.Storable +import Control.Monad.ST +import Data.Int +import Data.CairoContext +import Stopgap.Data.Ptr +import Stopgap.Graphics.UI.Gdk.Event.Button qualified as Gdk.Event.Button +import Stopgap.Graphics.UI.Gdk.Event.Motion qualified as Gdk.Event.Motion + +#include + +data CTag + +newtype C fun = C (FunPtr CTag) deriving Show + +foreign import capi "gtk/gtk.h G_CALLBACK" c_G_CALLBACK :: FunPtr fun -> C fun + +c_ab :: (IsPtr a, IsPtr b) => + (a -> b -> IO ()) -> IO (C (Ptr (Tag a) -> Ptr (Tag b) -> IO ())) +c_ab f = do + let f' x y = f (fromPtr x) (fromPtr y) + c_G_CALLBACK <$> c_wrap_callback_ab f' + +foreign import ccall "wrapper" c_wrap_callback_ab :: + (Ptr a -> Ptr b -> IO ()) -> IO (FunPtr (Ptr a -> Ptr b -> IO ())) + +c_ab_bool :: (IsPtr a, IsPtr b) => + (a -> b -> IO Bool) -> IO (C (Ptr (Tag a) -> Ptr (Tag b) -> IO #{type gboolean})) +c_ab_bool f = do + let f' x y = boolToGboolean <$> f (fromPtr x) (fromPtr y) + c_G_CALLBACK <$> c_wrap_callback_ab_bool f' + +boolToGboolean :: Bool -> #{type gboolean} +boolToGboolean = \case False -> #{const FALSE}; True -> #{const TRUE} + +foreign import ccall "wrapper" c_wrap_callback_ab_bool :: + (Ptr a -> Ptr b -> IO #{type gboolean}) -> + IO (FunPtr (Ptr a -> Ptr b -> IO #{type gboolean})) + +c_void_void :: IO () -> IO (C (IO ())) +c_void_void f = c_G_CALLBACK <$> c_wrap_callback_void_void f + +foreign import ccall "wrapper" c_wrap_callback_void_void :: + IO () -> IO (FunPtr (IO ())) + +c_self_cairo_ud :: (IsPtr a, IsPtr b) => + (a -> CairoT r RealWorld -> b -> IO Bool) -> + IO (C ( Ptr (Tag a) -> Ptr (CairoT r RealWorld) -> Ptr (Tag b) -> + IO #{type gboolean})) +c_self_cairo_ud f = do + let f' x cr y = boolToGboolean <$> do + cr' <- CairoT <$> newForeignPtr cr (pure ()) + f (fromPtr x) cr' (fromPtr y) + c_G_CALLBACK <$> c_wrap_callback_self_cairo_ud f' + +foreign import ccall "wrapper" c_wrap_callback_self_cairo_ud :: + (Ptr a -> Ptr (CairoT r s) -> Ptr b -> IO #{type gboolean}) -> + IO (FunPtr (Ptr a -> Ptr (CairoT r s) -> Ptr b -> IO #{type gboolean})) + +c_self_button_ud :: (IsPtr a, IsPtr b) => + (a -> Gdk.Event.Button.B -> b -> IO Bool) -> + IO (C ( Ptr (Tag a) -> Ptr Gdk.Event.Button.B -> Ptr (Tag b) -> + IO #{type gboolean})) +c_self_button_ud f = do + let f' x eb y = boolToGboolean <$> do + eb' <- peek eb + f (fromPtr x) eb' (fromPtr y) + c_G_CALLBACK <$> c_wrap_callback_self_button_ud f' + +foreign import ccall "wrapper" c_wrap_callback_self_button_ud :: + (Ptr a -> Ptr Gdk.Event.Button.B -> Ptr b -> IO #{type gboolean}) -> + IO (FunPtr ( + Ptr a -> Ptr Gdk.Event.Button.B -> Ptr b -> + IO #{type gboolean} )) + +c_self_motion_ud :: (IsPtr a, IsPtr b) => + (a -> Gdk.Event.Motion.M -> b -> IO Bool) -> + IO (C ( Ptr (Tag a) -> Ptr Gdk.Event.Motion.M -> Ptr (Tag b) -> + IO #{type gboolean})) +c_self_motion_ud f = do + let f' x eb y = boolToGboolean <$> do + eb' <- peek eb + f (fromPtr x) eb' (fromPtr y) + c_G_CALLBACK <$> c_wrap_callback_self_motion_ud f' + +foreign import ccall "wrapper" c_wrap_callback_self_motion_ud :: + (Ptr a -> Ptr Gdk.Event.Motion.M -> Ptr b -> IO #{type gboolean}) -> + IO (FunPtr ( + Ptr a -> Ptr Gdk.Event.Motion.M -> Ptr b -> + IO #{type gboolean} )) diff --git a/src/Stopgap/System/GLib/Object.hsc b/src/Stopgap/System/GLib/Object.hsc new file mode 100644 --- /dev/null +++ b/src/Stopgap/System/GLib/Object.hsc @@ -0,0 +1,13 @@ +{-# LANGUAGE ImportQualifiedPost #-} +{-# OPTIONS_GHC -Wall -fno-warn-tabs #-} + +module Stopgap.System.GLib.Object where + +import Foreign.Ptr +import Stopgap.Data.Ptr + +data OTag + +newtype O = O (Ptr OTag) deriving Show + +class IsPtr o => IsO o where toO :: o -> O diff --git a/src/Stopgap/System/GLib/Signal.hsc b/src/Stopgap/System/GLib/Signal.hsc new file mode 100644 --- /dev/null +++ b/src/Stopgap/System/GLib/Signal.hsc @@ -0,0 +1,59 @@ +{-# LANGUAGE ImportQualifiedPost #-} +{-# LANGUAGE CApiFFI #-} +{-# LANGUAGE BlockArguments #-} +{-# OPTIONS_GHC -Wall -fno-warn-tabs #-} + +module Stopgap.System.GLib.Signal where + +import Foreign.Ptr +import Foreign.C.String +import Control.Monad.ST +import Data.String +import Data.CairoContext +import Stopgap.Data.Ptr +import Stopgap.System.GLib.Object qualified as G.Object +import Stopgap.System.GLib.Callback qualified as G.Callback +import Stopgap.Graphics.UI.Gdk.Event.Button qualified as Gdk.Event.Button +import Stopgap.Graphics.UI.Gdk.Event.Motion qualified as Gdk.Event.Motion + +newtype Signal = Signal String deriving Show + +instance IsString Signal where fromString = Signal + +connect_ab :: (G.Object.IsO a, IsPtr b) => + a -> Signal -> (a -> b -> IO ()) -> b -> IO () +connect_ab o (Signal sig) h ud = withCString sig \csig -> do + ch <- G.Callback.c_ab h + c_g_signal_connect (toPtr o) csig ch (toPtr ud) + +connect_ab_bool :: (G.Object.IsO a, IsPtr b) => + a -> Signal -> (a -> b -> IO Bool) -> b -> IO () +connect_ab_bool o (Signal sig) h ud = withCString sig \csig -> do + ch <- G.Callback.c_ab_bool h + c_g_signal_connect (toPtr o) csig ch (toPtr ud) + +connect_void_void :: G.Object.IsO a => a -> Signal -> IO () -> Null -> IO () +connect_void_void o (Signal sig) h Null = withCString sig \csig -> do + ch <- G.Callback.c_void_void h + c_g_signal_connect (toPtr o) csig ch nullPtr + +connect_self_cairo_ud :: (G.Object.IsO a, IsPtr b) => + a -> Signal -> (a -> CairoT r RealWorld -> b -> IO Bool) -> b -> IO () +connect_self_cairo_ud o (Signal sig) h ud = withCString sig \csig -> do + ch <- G.Callback.c_self_cairo_ud h + c_g_signal_connect (toPtr o) csig ch (toPtr ud) + +connect_self_button_ud :: (G.Object.IsO a, IsPtr b) => + a -> Signal -> (a -> Gdk.Event.Button.B -> b -> IO Bool) -> b -> IO () +connect_self_button_ud o (Signal sig) h ud = withCString sig \csig -> do + ch <- G.Callback.c_self_button_ud h + c_g_signal_connect (toPtr o) csig ch (toPtr ud) + +connect_self_motion_ud :: (G.Object.IsO a, IsPtr b) => + a -> Signal -> (a -> Gdk.Event.Motion.M -> b -> IO Bool) -> b -> IO () +connect_self_motion_ud o (Signal sig) h ud = withCString sig \csig -> do + ch <- G.Callback.c_self_motion_ud h + c_g_signal_connect (toPtr o) csig ch (toPtr ud) + +foreign import capi "gtk/gtk.h g_signal_connect" c_g_signal_connect :: + Ptr a -> CString -> G.Callback.C fun -> Ptr b -> IO () diff --git a/test/Spec.hs b/test/Spec.hs new file mode 100644 --- /dev/null +++ b/test/Spec.hs @@ -0,0 +1,2 @@ +main :: IO () +main = putStrLn "Test suite not yet implemented"