packages feed

moffy-samples-gtk4-run (empty) → 0.1.0.0

raw patch · 37 files changed

+1725/−0 lines, 37 filesdep +basedep +c-enumdep +c-structsetup-changed

Dependencies added: base, c-enum, c-struct, exception-hierarchy, moffy, moffy-samples-events, moffy-samples-gtk4-run, random, simple-cairo, simple-pango, stm, text, time, type-flip, type-set, union-color

Files

+ CHANGELOG.md view
@@ -0,0 +1,11 @@+# Changelog for `moffy-samples-gtk4-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
+ LICENSE view
@@ -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.
+ README.md view
@@ -0,0 +1,1 @@+# moffy-samples-gtk4-run
+ Setup.hs view
@@ -0,0 +1,2 @@+import Distribution.Simple+main = defaultMain
+ moffy-samples-gtk4-run.cabal view
@@ -0,0 +1,115 @@+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-gtk4-run+version:        0.1.0.0+synopsis:       Package to run moffy samples - Gtk4 version+description:    Please see the README on GitHub at <https://github.com/YoshikuniJujo/moffy-samples-gtk4-run#readme>+category:       Control+homepage:       https://github.com/YoshikuniJujo/moffy-samples-gtk4-run#readme+bug-reports:    https://github.com/YoshikuniJujo/moffy-samples-gtk4-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-gtk4-run++library+  exposed-modules:+      Control.Moffy.Samples.Boxes.Run.Gtk4+      Control.Moffy.Samples.Followbox.Run.Gtk4+      Control.Moffy.Samples.Run.Gtk4+      Stopgap.Data.Ptr+      Stopgap.Graphics.UI.Gtk+      Stopgap.Graphics.UI.Gtk.Application+      Stopgap.Graphics.UI.Gtk.ApplicationWindow+      Stopgap.Graphics.UI.Gtk.Box+      Stopgap.Graphics.UI.Gtk.Button+      Stopgap.Graphics.UI.Gtk.DrawingArea+      Stopgap.Graphics.UI.Gtk.EventController+      Stopgap.Graphics.UI.Gtk.EventControllerMotion+      Stopgap.Graphics.UI.Gtk.Gesture+      Stopgap.Graphics.UI.Gtk.GestureClick+      Stopgap.Graphics.UI.Gtk.Label+      Stopgap.Graphics.UI.Gtk.Notebook+      Stopgap.Graphics.UI.Gtk.NotebookPage+      Stopgap.Graphics.UI.Gtk.ScrolledWindow+      Stopgap.Graphics.UI.Gtk.TextBuffer+      Stopgap.Graphics.UI.Gtk.TextView+      Stopgap.Graphics.UI.Gtk.Widget+      Stopgap.Graphics.UI.Gtk.Window+      Stopgap.System.GLib.Application+      Stopgap.System.GLib.Cancellable+      Stopgap.System.GLib.Error+      Stopgap.System.GLib.Error.Io+      Stopgap.System.GLib.File+      Stopgap.System.GLib.Idle+      Stopgap.System.GLib.Object+      Stopgap.System.GLib.Signal+      Stopgap.System.GLib.Timeout+  other-modules:+      Paths_moffy_samples_gtk4_run+  autogen-modules:+      Paths_moffy_samples_gtk4_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:+      gtk4+  build-depends:+      base >=4.7 && <5+    , c-enum+    , c-struct+    , exception-hierarchy+    , 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-gtk4-run-test+  type: exitcode-stdio-1.0+  main-is: Spec.hs+  other-modules:+      Paths_moffy_samples_gtk4_run+  autogen-modules:+      Paths_moffy_samples_gtk4_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+    , exception-hierarchy+    , moffy+    , moffy-samples-events+    , moffy-samples-gtk4-run+    , random+    , simple-cairo+    , simple-pango+    , stm+    , text+    , time+    , type-flip+    , type-set+    , union-color+  default-language: Haskell2010
+ src/Control/Moffy/Samples/Boxes/Run/Gtk4.hs view
@@ -0,0 +1,75 @@+{-# LANGUAGE ImportQualifiedPost #-}+{-# LANGUAGE BlockArguments, LambdaCase #-}+{-# LANGUAGE ScopedTypeVariables, TypeApplications #-}+{-# LANGUAGE MonoLocalBinds #-}+{-# LANGUAGE DataKinds #-}+{-# LANGUAGE TypeOperators #-}+{-# LANGUAGE FlexibleContexts #-}+{-# OPTIONS_GHC -Wall -fno-warn-tabs #-}++module Control.Moffy.Samples.Boxes.Run.Gtk4 (runBoxes) where++import Prelude hiding (until)+import Control.Monad+import Control.Concurrent+import Control.Concurrent.STM+import Control.Moffy+import Control.Moffy.Event.Time+import Control.Moffy.Handle qualified as H+import Control.Moffy.Handle.Time+import Control.Moffy.Samples.Event.Mouse qualified as Mouse+import Control.Moffy.Samples.Event.Delete+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.Run.Gtk4+import Control.Moffy.Samples.Boxes.Viewable+import Data.Type.Set+import Data.Type.Flip+import Data.Maybe+import Data.Time.Clock.System+import Data.Color++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 [Box] r -> IO ()+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+			(H.retrySt . ($ (0.05, ())) . H.popInput . handleTimeEvPlus . H.pushInput . const . H.liftHandle' . H.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
+ src/Control/Moffy/Samples/Followbox/Run/Gtk4.hs view
@@ -0,0 +1,66 @@+{-# LANGUAGE ImportQualifiedPost #-}+{-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE DataKinds #-}+{-# LANGUAGE TypeOperators #-}+{-# LANGUAGE PatternSynonyms #-}+{-# OPTIONS_GHC -Wall -fno-warn-tabs #-}++module Control.Moffy.Samples.Followbox.Run.Gtk4 (runFollowbox) where++import Control.Concurrent+import Control.Moffy+import Control.Moffy.Samples.Event.CalcTextExtents+import Control.Moffy.Samples.Handle.TChan+import Control.Moffy.Samples.Run.TChan+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.Gtk4++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++runFollowbox :: String -> Sig s FollowboxEv T.View () -> IO ()+runFollowbox brws sig = runFollowbox_ brws Nothing $ viewToView <$%> sig++runFollowbox_ :: String -> Maybe GithubNameToken -> Sig s FollowboxEv View () -> IO ()+runFollowbox_ brws tkn sig = do+	(cer, ceo, cv) <- atomically $+		(,,) <$> newTChan <*> newTChan <*> newTChan+	_ <- forkIO $ runFollowboxGen cer ceo brws tkn cv (sig >> emit Stopped)+	runSingleWin cer ceo cv++runFollowboxGen ::+	TChan (EvReqs (CalcTextExtents :- GuiEv)) -> TChan (EvOccs (CalcTextExtents :- GuiEv)) -> String ->+	Maybe GithubNameToken -> TChan x -> Sig s FollowboxEv x r -> IO r+runFollowboxGen cr c brs mgnt c' s = do+	(r, _) <- interpretSt (handleFollowbox (cr, c) brs mgnt) c' s (initialFollowboxState $ mkStdGen 8)+	pure r++handleFollowbox ::+	(TChan (EvReqs (CalcTextExtents :- GuiEv)), TChan (EvOccs (CalcTextExtents :- GuiEv))) -> Browser ->+	Maybe GithubNameToken -> HandleF IO (CalcTextExtents :- GuiEv :+: FollowboxEv)+handleFollowbox = handleFollowboxWith (uncurry . handle)++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)
+ src/Control/Moffy/Samples/Run/Gtk4.hs view
@@ -0,0 +1,244 @@+{-# LANGUAGE ImportQualifiedPost #-}+{-# LANGUAGE BlockArguments, LambdaCase #-}+{-# LANGUAGE TypeOperators #-}+{-# LANGUAGE ViewPatterns #-}+{-# OPTIONS_GHC -Wall -fno-warn-tabs #-}++module Control.Moffy.Samples.Run.Gtk4 (runSingleWin) where++import Control.Monad+import Control.Monad.ST+import Control.Concurrent+import Control.Concurrent.STM+import Control.Moffy+import Control.Moffy.Samples.Event.Mouse qualified as Mouse+import Control.Moffy.Samples.Event.Delete+import Control.Moffy.Samples.View+import Control.Moffy.Samples.Event.CalcTextExtents+import Data.Type.Set+import Data.OneOrMore qualified as OOM+import Data.OneOrMoreApp+import Data.Maybe+import Data.Int+import Data.Text qualified as T+import Data.Color+import Stopgap.Data.Ptr+import System.Exit++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.Graphics.UI.Gtk.Application qualified as Gtk.Application+import Stopgap.Graphics.UI.Gtk.Widget qualified as Gtk.Widget+import Stopgap.Graphics.UI.Gtk.ApplicationWindow qualified as+	Gtk.ApplicationWindow+import Stopgap.Graphics.UI.Gtk.Window qualified as Gtk.Window+import Stopgap.Graphics.UI.Gtk.DrawingArea qualified as Gtk.DrawingArea+import Stopgap.Graphics.UI.Gtk.EventControllerMotion qualified as+	Gtk.EventControllerMotion+import Stopgap.Graphics.UI.Gtk.GestureClick qualified as Gtk.GestureClick+import Stopgap.System.GLib.Application qualified as G.Application+import Stopgap.System.GLib.Signal qualified as G.Signal+import Stopgap.System.GLib.Idle qualified as G.Idle++beforeClose :: TChan (EvOccs (CalcTextExtents :- Mouse.Move :- Mouse.Down :- Mouse.Up :- Singleton DeleteEvent)) ->+	Gtk.ApplicationWindow.A -> Null -> IO Bool+beforeClose ceo win Null =+	True <$ atomically (writeTChan ceo . expand $ Singleton OccDeleteEvent)++appActivate ::+	TChan (EvReqs (CalcTextExtents :- Mouse.Move :- Mouse.Down :- Mouse.Up :- Singleton DeleteEvent)) ->+	TChan (EvOccs (CalcTextExtents :- Mouse.Move :- Mouse.Down :- Mouse.Up :- Singleton DeleteEvent)) ->+	TChan View ->+	Gtk.Application.A s -> Null -> IO ()+appActivate cer ceo cv app Null = do+	crd <- atomically $ newTVar []+	cte <- atomically newTChan+	win <- Gtk.ApplicationWindow.new app+	da <- Gtk.DrawingArea.new+	Gtk.DrawingArea.setDrawFunc da (drawFunction crd ceo cte) Null++	gcp <- mouseButtonHandler ceo Mouse.ButtonPrimary+	gcm <- mouseButtonHandler ceo Mouse.ButtonMiddle+	gcs <- mouseButtonHandler ceo Mouse.ButtonSecondary++	ecm <- Gtk.EventControllerMotion.new+	G.Signal.connectXY ecm (G.Signal.Signal "motion") (moveHandler ceo) Null++	Gtk.Window.setChild win da+	Gtk.Widget.addController da gcp+	Gtk.Widget.addController da gcm+	Gtk.Widget.addController da gcs+	Gtk.Widget.addController da ecm++	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.Idle.add+					(\_ ->	Gtk.Widget.queueDraw da >>+						pure False)+					Null++	forkIO . forever $ atomically (readTChan cv) >>= \case+		Stopped -> void $ G.Idle.add+			(\_ -> Gtk.Window.destroy win >> pure False) Null+		View v -> do+			atomically $ writeTVar crd v+			void $ G.Idle.add+				(\_ -> Gtk.Widget.queueDraw da >> pure False)+				Null+		v -> print v++	G.Signal.connectClose win (G.Signal.Signal "close-request") (beforeClose ceo) Null++	Gtk.Window.present win++appId :: Gtk.Application.Id+appId = Gtk.Application.Id "com.github.YoshikuniJujo.moffy-samples-run"++runSingleWin ::+	TChan (EvReqs (CalcTextExtents :- Mouse.Move :- Mouse.Down :- Mouse.Up :- Singleton DeleteEvent)) ->+	TChan (EvOccs (CalcTextExtents :- Mouse.Move :- Mouse.Down :- Mouse.Up :- Singleton DeleteEvent)) ->+	TChan View -> IO ()+runSingleWin cer ceo cv = Gtk.Application.with+		appId G.Application.DefaultFlags \app -> do+	G.Signal.connect app (G.Signal.Signal "activate") (appActivate cer ceo cv) Null+--	exitWith =<< join (G.Application.run app <$> getProgName <*> getArgs)+	exitWith =<< G.Application.run app "run" []++pressHandler ::+	TChan (EvOccs (CalcTextExtents :- Mouse.Move :- Mouse.Down :- Mouse.Up :- Singleton DeleteEvent)) ->+	Mouse.Button ->+	Gtk.GestureClick.G -> Int32 -> Double -> Double -> Null -> IO ()+pressHandler ceo b _gc n x y Null = atomically . writeTChan ceo+	$ expand (Mouse.OccMove (x, y) >- Singleton (Mouse.OccDown b) ::+		EvOccs (Mouse.Move :- Singleton Mouse.Down))++releaseHandler ::+	TChan (EvOccs (CalcTextExtents :- Mouse.Move :- Mouse.Down :- Mouse.Up :- Singleton DeleteEvent)) ->+	Mouse.Button ->+	Gtk.GestureClick.G -> Int32 -> Double -> Double -> Null -> IO ()+releaseHandler ceo b _gc n x y Null = atomically . writeTChan ceo+	$ expand (Mouse.OccMove (x, y) >- Singleton (Mouse.OccUp b) ::+		EvOccs (Mouse.Move :- Singleton Mouse.Up))++mouseButtonHandler ::+	TChan (EvOccs (CalcTextExtents :- Mouse.Move :- Mouse.Down :- Mouse.Up :- Singleton DeleteEvent)) ->+	Mouse.Button ->+	IO Gtk.GestureClick.G+mouseButtonHandler ceo b = do+	gcp <- Gtk.GestureClick.new+	Gtk.GestureClick.setButton gcp (mouseButtonToGesture b)+	G.Signal.connectNXY gcp+		(G.Signal.Signal "pressed") (pressHandler ceo b) Null+	G.Signal.connectNXY gcp+		(G.Signal.Signal "released") (releaseHandler ceo b) Null+	pure gcp++moveHandler ::+	TChan (EvOccs (CalcTextExtents :- Mouse.Move :- Mouse.Down :- Mouse.Up :- Singleton DeleteEvent)) ->+	Gtk.EventControllerMotion.E -> Double -> Double -> Null -> IO ()+moveHandler ceo _ x y Null = atomically . writeTChan ceo+	. expand $ Singleton (Mouse.OccMove (x, y))++type GuiEv = Mouse.Move :- Mouse.Down :- Mouse.Up :- Singleton DeleteEvent++viewHandler :: TChan view -> Gtk.ApplicationWindow.A -> IO Bool+viewHandler cv win = do+	atomically $ readTChan cv+	putStrLn "VIEW HANDLER"+	pure True++mouseButtonToGesture :: Mouse.Button -> Gtk.GestureClick.Button+mouseButtonToGesture = \case+	Mouse.ButtonPrimary -> Gtk.GestureClick.ButtonPrimary+	Mouse.ButtonMiddle -> Gtk.GestureClick.ButtonMiddle+	Mouse.ButtonSecondary -> Gtk.GestureClick.ButtonSecondary++drawFunction :: TVar [View1] ->+	TChan (EvOccs (CalcTextExtents :- Mouse.Move :- Mouse.Down :- Mouse.Up :- Singleton DeleteEvent)) ->+	TChan (FontName, FontSize, T.Text) ->+	Gtk.DrawingArea.DrawFunction r Null+drawFunction crd ceo cte area cr width height 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+	cairoSetLineWidth cr 2+	(drawView1 cr `mapM_`) =<< atomically (readTVar crd)++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+	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
+ src/Stopgap/Data/Ptr.hs view
@@ -0,0 +1,18 @@+{-# LANGUAGE TypeFamilies, TypeFamilyDependencies #-}+{-# 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
+ src/Stopgap/Graphics/UI/Gtk.hsc view
@@ -0,0 +1,24 @@+{-# LANGUAGE TemplateHaskell #-}+{-# LANGUAGE PatternSynonyms #-}+{-# LANGUAGE GeneralizedNewtypeDeriving #-}+{-# OPTIONS_GHC -Wall -fno-warn-tabs #-}++module Stopgap.Graphics.UI.Gtk where++import Foreign.C.Enum+import Foreign.C.Types+import Data.Word++#include <gtk/gtk.h>++newtype Pixel = Pixel CInt deriving (Show, Num)++enum "Orientation" ''#{type GtkOrientation} [''Show, ''Read] [+	("OrientationHorizontal", #{const GTK_ORIENTATION_HORIZONTAL}),+	("OrientationVertical", #{const GTK_ORIENTATION_VERTICAL}) ]++enum "WrapMode" ''#{type GtkWrapMode} [''Show, ''Read] [+	("WrapNone", #{const GTK_WRAP_NONE}),+	("WrapChar", #{const GTK_WRAP_CHAR}),+	("WrapWord", #{const GTK_WRAP_WORD}),+	("WrapWordChar", #{const GTK_WRAP_WORD_CHAR}) ]
+ src/Stopgap/Graphics/UI/Gtk/Application.hsc view
@@ -0,0 +1,49 @@+{-# LANGUAGE ImportQualifiedPost #-}+{-# LANGUAGE CApiFFI #-}+{-# LANGUAGE BlockArguments #-}+{-# LANGUAGE RankNTypes #-}+{-# LANGUAGE TypeFamilies #-}+{-# OPTIONS_GHC -Wall -fno-warn-tabs #-}++module Stopgap.Graphics.UI.Gtk.Application where++import Foreign.Ptr+import Foreign.C.String+import Data.Word+import Data.String++import Stopgap.System.GLib.Object qualified as G.Object+import Stopgap.System.GLib.Application qualified as G.Application+import Stopgap.Data.Ptr++#include <gtk/gtk.h>++data ATag++newtype A s = A (Ptr ATag) deriving Show++instance G.Application.IsA (A s) where toA = gApplication++instance IsPtr (A s) where+	type Tag (A s) = ATag+	fromPtr = A+	toPtr (A p) = p++instance G.Object.IsO (A s) where toO (A p) = G.Object.O $ castPtr p++data Id = Id String deriving Show++instance IsString Id where fromString = Id++with :: Id -> G.Application.Flags -> (forall s . A s -> IO a) -> IO a+with (Id aid) (G.Application.Flags flgs) f = G.Object.withObject+	(A <$> withCString aid \caid -> c_gtk_application_new caid flgs) f++foreign import ccall "gtk_application_new" c_gtk_application_new ::+	CString -> #{type GApplicationFlags} -> IO (Ptr ATag)++gApplication :: A s -> G.Application.A+gApplication (A pa) = G.Application.A $ c_G_APPLICATION pa++foreign import capi "gtk/gtk.h G_APPLICATION" c_G_APPLICATION ::+	Ptr ATag -> Ptr G.Application.ATag
+ src/Stopgap/Graphics/UI/Gtk/ApplicationWindow.hsc view
@@ -0,0 +1,36 @@+{-# LANGUAGE ImportQualifiedPost #-}+{-# LANGUAGE CApiFFI #-}+{-# LANGUAGE TypeFamilies #-}+{-# OPTIONS_GHC -Wall -fno-warn-tabs #-}++module Stopgap.Graphics.UI.Gtk.ApplicationWindow where++import Foreign.Ptr+import Stopgap.Data.Ptr++import Stopgap.Graphics.UI.Gtk.Widget qualified as Gtk.Widget+import Stopgap.Graphics.UI.Gtk.Window qualified as Gtk.Window+import Stopgap.Graphics.UI.Gtk.Application qualified as Gtk.Application+import Stopgap.System.GLib.Object qualified as G.Object++data ATag++newtype A = A (Ptr ATag) deriving Show++instance IsPtr A where type Tag A = ATag; fromPtr = A; toPtr (A p) = p+instance G.Object.IsO A where toO (A a) = G.Object.O $ castPtr a+instance Gtk.Widget.IsW A where toW (A a) = Gtk.Widget.W $ castPtr a+instance Gtk.Window.IsW A where toW = window++new :: Gtk.Application.A s -> IO A+new (Gtk.Application.A a) = A <$> c_gtk_application_window_new a++foreign import ccall "gtk_application_window_new"+	c_gtk_application_window_new ::+	Ptr Gtk.Application.ATag -> IO (Ptr ATag)++window :: A -> Gtk.Window.W+window (A a) = Gtk.Window.W $ c_GTK_WINDOW a++foreign import capi "gtk/gtk.h GTK_WINDOW" c_GTK_WINDOW ::+	Ptr ATag -> Ptr Gtk.Window.WTag
+ src/Stopgap/Graphics/UI/Gtk/Box.hsc view
@@ -0,0 +1,48 @@+{-# LANGUAGE ImportQualifiedPost #-}+{-# LANGUAGE LambdaCase #-}+{-# LANGUAGE TypeFamilies #-}+{-# LANGUAGE ViewPatterns #-}+{-# OPTIONS_GHC -Wall -fno-warn-tabs #-}++module Stopgap.Graphics.UI.Gtk.Box where++import Foreign.Ptr+import Foreign.C.Types+import Data.Word+import Data.Int+import Stopgap.Data.Ptr++import Stopgap.Graphics.UI.Gtk qualified as Gtk+import Stopgap.Graphics.UI.Gtk.Widget qualified as Gtk.Widget+import Stopgap.System.GLib.Object qualified as G.Object++#include <gtk/gtk.h>++data BTag++newtype B = B (Ptr BTag) deriving Show++instance IsPtr B where type Tag B = BTag; fromPtr = B; toPtr (B p) = p+instance G.Object.IsO B where toO (B p) = G.Object.O $ castPtr p+instance Gtk.Widget.IsW B where toW (B p) = Gtk.Widget.W $ castPtr p++new :: Gtk.Orientation -> Gtk.Pixel -> IO B+new (Gtk.Orientation o) (Gtk.Pixel p) = B <$> c_gtk_box_new o p++foreign import ccall "gtk_box_new" c_gtk_box_new ::+	#{type GtkOrientation} -> CInt -> IO (Ptr BTag)++append :: Gtk.Widget.IsW w => B -> w -> IO ()+append (B b) (Gtk.Widget.toW -> Gtk.Widget.W w) = c_gtk_box_append b w++foreign import ccall "gtk_box_append" c_gtk_box_append ::+	Ptr BTag -> Ptr Gtk.Widget.WTag -> IO ()++setHomogeneous :: B -> Bool -> IO ()+setHomogeneous (B bx) (boolToGBoolean -> bl) = c_gtk_box_set_homogeneous bx bl++boolToGBoolean :: Bool -> #{type gboolean}+boolToGBoolean = \case False -> #{const FALSE}; True -> #{const TRUE}++foreign import ccall "gtk_box_set_homogeneous" c_gtk_box_set_homogeneous ::+	Ptr BTag -> #{type gboolean} -> IO ()
+ src/Stopgap/Graphics/UI/Gtk/Button.hsc view
@@ -0,0 +1,38 @@+{-# LANGUAGE ImportQualifiedPost #-}+{-# LANGUAGE TypeFamilies #-}+{-# OPTIONS_GHC -Wall -fno-warn-tabs #-}++module Stopgap.Graphics.UI.Gtk.Button where++import Foreign.Ptr+import Foreign.C.String+import Stopgap.Data.Ptr++import Stopgap.Graphics.UI.Gtk.Widget qualified as Gtk.Widget+import Stopgap.System.GLib.Object qualified as G.Object++data BTag++newtype B = B (Ptr BTag) deriving Show++instance IsPtr B where type Tag B = BTag; fromPtr = B; toPtr (B p) = p+instance G.Object.IsO B where toO (B p) = G.Object.O $ castPtr p+instance Gtk.Widget.IsW B where toW (B p) = Gtk.Widget.W $ castPtr p++newWithLabel :: String -> IO B+newWithLabel lbl = B <$> withCString lbl c_gtk_button_new_with_label++foreign import ccall "gtk_button_new_with_label" c_gtk_button_new_with_label ::+	CString -> IO (Ptr BTag)++getLabel :: B -> IO String+getLabel (B b) = peekCString =<< c_gtk_button_get_label b++foreign import ccall "gtk_button_get_label" c_gtk_button_get_label ::+	Ptr BTag -> IO CString++setLabel :: B -> String -> IO ()+setLabel (B b) txt = withCString txt $ c_gtk_button_set_label b++foreign import ccall "gtk_button_set_label" c_gtk_button_set_label ::+	Ptr BTag -> CString -> IO ()
+ src/Stopgap/Graphics/UI/Gtk/DrawingArea.hsc view
@@ -0,0 +1,58 @@+{-# LANGUAGE ImportQualifiedPost #-}+{-# LANGUAGE TypeFamilies #-}+{-# OPTIONS_GHC -Wall -fno-warn-tabs #-}++module Stopgap.Graphics.UI.Gtk.DrawingArea where++import Foreign.Ptr+import Foreign.Concurrent+import Control.Monad.ST+import Data.Int+import Stopgap.Data.Ptr++import Data.CairoContext+import Graphics.Cairo.Drawing.CairoT++import Stopgap.Graphics.UI.Gtk.Widget qualified as Gtk.Widget+import Stopgap.System.GLib.Object qualified as G.Object++data DTag++newtype D = D (Ptr DTag) deriving Show++instance IsPtr D where type Tag D = DTag; fromPtr = D; toPtr (D p) = p+instance G.Object.IsO D where toO (D d) = G.Object.O $ castPtr d+instance Gtk.Widget.IsW D where toW (D d) = Gtk.Widget.W $ castPtr d++new :: IO D+new = D <$> c_gtk_drawing_area_new++foreign import ccall "gtk_drawing_area_new" c_gtk_drawing_area_new ::+	IO (Ptr DTag)++setDrawFunc :: IsPtr ud => D -> DrawFunction r ud -> ud -> IO ()+setDrawFunc (D d) f ud = do+	cf <- wrapDrawFunction f+	c_gtk_drawing_area_set_draw_func d cf (toPtr ud) nullPtr++foreign import ccall "gtk_drawing_area_set_draw_func"+	c_gtk_drawing_area_set_draw_func ::+	Ptr DTag -> FunPtr (CDrawFunction r ud) -> Ptr ud -> Ptr () -> IO ()++wrapDrawFunction :: IsPtr ud => DrawFunction r ud -> IO (FunPtr (CDrawFunction r (Tag ud)))+wrapDrawFunction = c_wrapDrawFunction . drawFunctionToC++drawFunctionToC :: IsPtr ud => DrawFunction r ud -> CDrawFunction r (Tag ud)+drawFunctionToC f pd pcr w h pud = do+	cr <- CairoT <$> newForeignPtr pcr (pure ())+	f (D pd) cr w h (fromPtr pud)++type DrawFunction r ud =+	D -> CairoT r RealWorld -> #{type int} -> #{type int} -> ud -> IO ()++type CDrawFunction r ud =+	Ptr DTag -> Ptr (CairoT r RealWorld) -> #{type int} -> #{type int} ->+	Ptr ud -> IO ()++foreign import ccall "wrapper" c_wrapDrawFunction ::+	CDrawFunction r ud -> IO (FunPtr (CDrawFunction r ud))
+ src/Stopgap/Graphics/UI/Gtk/EventController.hsc view
@@ -0,0 +1,14 @@+{-# LANGUAGE ImportQualifiedPost #-}+{-# OPTIONS_GHC -Wall -fno-warn-tabs #-}++module Stopgap.Graphics.UI.Gtk.EventController where++import Foreign.Ptr++import Stopgap.System.GLib.Object qualified as G.Object++data ETag++newtype E = E (Ptr ETag) deriving Show++class G.Object.IsO e => IsE e where toE :: e -> E
+ src/Stopgap/Graphics/UI/Gtk/EventControllerMotion.hsc view
@@ -0,0 +1,27 @@+{-# LANGUAGE ImportQualifiedPost #-}+{-# LANGUAGE TypeFamilies #-}+{-# OPTIONS_GHC -Wall -fno-warn-tabs #-}++module Stopgap.Graphics.UI.Gtk.EventControllerMotion where++import Foreign.Ptr+import Stopgap.Data.Ptr++import Stopgap.Graphics.UI.Gtk.EventController qualified as Gtk.EventController+import Stopgap.System.GLib.Object qualified as G.Object++data ETag++newtype E = E (Ptr ETag) deriving Show++instance IsPtr E where type Tag E = ETag; fromPtr = E; toPtr (E p) = p+instance G.Object.IsO E where toO (E e) = G.Object.O $ castPtr e++instance Gtk.EventController.IsE E where+	toE (E e) = Gtk.EventController.E $ castPtr e++new :: IO E+new = E <$> c_gtk_event_controller_motion_new++foreign import ccall "gtk_event_controller_motion_new"+	c_gtk_event_controller_motion_new :: IO (Ptr ETag)
+ src/Stopgap/Graphics/UI/Gtk/Gesture.hsc view
@@ -0,0 +1,23 @@+{-# LANGUAGE ImportQualifiedPost #-}+{-# LANGUAGE TypeFamilies #-}+{-# OPTIONS_GHC -Wall -fno-warn-tabs #-}++module Stopgap.Graphics.UI.Gtk.Gesture where++import Foreign.Ptr+import Stopgap.Data.Ptr++import Stopgap.Graphics.UI.Gtk.EventController qualified as Gtk.EventController+import Stopgap.System.GLib.Object qualified as G.Object++data GTag++newtype G = G (Ptr GTag) deriving Show++class Gtk.EventController.IsE g => IsG g where toG :: g -> G++instance IsPtr G where type Tag G = GTag; fromPtr = G; toPtr (G p) = p+instance G.Object.IsO G where toO (G g) = G.Object.O $ castPtr g++instance Gtk.EventController.IsE G where+	toE (G g) = Gtk.EventController.E $ castPtr g
+ src/Stopgap/Graphics/UI/Gtk/GestureClick.hsc view
@@ -0,0 +1,49 @@+{-# LANGUAGE ImportQualifiedPost #-}+{-# LANGUAGE TemplateHaskell #-}+{-# LANGUAGE TypeFamilies #-}+{-# LANGUAGE PatternSynonyms #-}+{-# OPTIONS_GHC -Wall -fno-warn-tabs #-}++module Stopgap.Graphics.UI.Gtk.GestureClick where++import Foreign.Ptr+import Foreign.C.Enum+import Stopgap.Data.Ptr+import Data.Word++import Stopgap.Graphics.UI.Gtk.EventController qualified as Gtk.EventController+import Stopgap.Graphics.UI.Gtk.Gesture qualified as Gtk.Gesture+import Stopgap.System.GLib.Object qualified as G.Object++#include <gtk/gtk.h>++data GTag++newtype G = G (Ptr GTag) deriving Show++instance IsPtr G where type Tag G = GTag; fromPtr = G; toPtr (G p) = p+instance G.Object.IsO G where toO (G g) = G.Object.O $ castPtr g++instance Gtk.EventController.IsE G where+	toE (G g) = Gtk.EventController.E $ castPtr g++instance Gtk.Gesture.IsG G where toG (G g) = Gtk.Gesture.G $ castPtr g++new :: IO G+new = G <$> c_gtk_gesture_click_new++foreign import ccall "gtk_gesture_click_new" c_gtk_gesture_click_new ::+	IO (Ptr GTag)++enum "Button" ''#{type guint} [''Show, ''Read] [+	("ButtonPrimary", #{const GDK_BUTTON_PRIMARY}),+	("ButtonMiddle", #{const GDK_BUTTON_MIDDLE}),+	("ButtonSecondary", #{const GDK_BUTTON_SECONDARY})+	]++setButton :: G -> Button -> IO ()+setButton (G g) (Button b) = c_gtk_gesture_single_set_button g b++foreign import ccall "gtk_gesture_single_set_button"+	c_gtk_gesture_single_set_button ::+	Ptr GTag -> #{type guint} -> IO ()
+ src/Stopgap/Graphics/UI/Gtk/Label.hsc view
@@ -0,0 +1,26 @@+{-# LANGUAGE ImportQualifiedPost #-}+{-# LANGUAGE TypeFamilies #-}+{-# OPTIONS_GHC -Wall -fno-warn-tabs #-}++module Stopgap.Graphics.UI.Gtk.Label where++import Foreign.Ptr+import Foreign.C.String+import Stopgap.Data.Ptr++import Stopgap.Graphics.UI.Gtk.Widget qualified as Gtk.Widget+import Stopgap.System.GLib.Object qualified as G.Object++data LTag++newtype L = L (Ptr LTag) deriving Show++instance IsPtr L where type Tag L = LTag; fromPtr = L; toPtr (L p) = p+instance G.Object.IsO L where toO (L p) = G.Object.O $ castPtr p+instance Gtk.Widget.IsW L where toW (L p) = Gtk.Widget.W $ castPtr p++new :: String -> IO L+new txt = L <$> withCString txt c_gtk_label_new++foreign import ccall "gtk_label_new" c_gtk_label_new ::+	CString -> IO (Ptr LTag)
+ src/Stopgap/Graphics/UI/Gtk/Notebook.hsc view
@@ -0,0 +1,57 @@+{-# LANGUAGE ImportQualifiedPost #-}+{-# LANGUAGE TypeFamilies #-}+{-# LANGUAGE ViewPatterns #-}+{-# OPTIONS_GHC -Wall -fno-warn-tabs #-}++module Stopgap.Graphics.UI.Gtk.Notebook where++import Foreign.Ptr+import Data.Int+import Stopgap.Data.Ptr++import Stopgap.Graphics.UI.Gtk.Widget qualified as Gtk.Widget+import Stopgap.Graphics.UI.Gtk.NotebookPage qualified as Gtk.NotebookPage+import Stopgap.System.GLib.Object qualified as G.Object++#include <gtk/gtk.h>++data NTag++newtype N = N (Ptr NTag) deriving Show++instance IsPtr N where type Tag N = NTag; fromPtr = N; toPtr (N p) = p+instance G.Object.IsO N where toO (N p) = G.Object.O $ castPtr p+instance Gtk.Widget.IsW N where toW (N p) = Gtk.Widget.W $ castPtr p++new :: IO N+new = N <$> c_gtk_notebook_new++foreign import ccall "gtk_notebook_new" c_gtk_notebook_new :: IO (Ptr NTag)++appendPage :: (Gtk.Widget.IsW c, Gtk.Widget.IsW l) =>+	N -> c -> l -> IO #{type int}+appendPage (N n)+	(Gtk.Widget.toW -> Gtk.Widget.W c) (Gtk.Widget.toW -> Gtk.Widget.W l) =+	c_gtk_notebook_append_page n c l++foreign import ccall "gtk_notebook_append_page" c_gtk_notebook_append_page ::+	Ptr NTag -> Ptr Gtk.Widget.WTag -> Ptr Gtk.Widget.WTag -> IO #{type int}++getNPages :: N -> IO #{type int}+getNPages (N n) = c_gtk_notebook_get_n_pages n++foreign import ccall "gtk_notebook_get_n_pages" c_gtk_notebook_get_n_pages ::+	Ptr NTag -> IO #{type int}++getPage :: Gtk.Widget.IsW c => N -> c -> IO Gtk.NotebookPage.N+getPage (N n) (Gtk.Widget.toW -> Gtk.Widget.W c) =+	Gtk.NotebookPage.N <$> c_gtk_notebook_get_page n c++foreign import ccall "gtk_notebook_get_page" c_gtk_notebook_get_page ::+	Ptr NTag -> Ptr Gtk.Widget.WTag -> IO (Ptr Gtk.NotebookPage.NTag)++-- getNthPage :: N -> #{type gint} -> IO Gtk.NotebookPage.N+-- getNthPage (N n) num = Gtk.NotebookPage.N <$> c_gtk_notebook_get_nth_page n num++foreign import ccall "gtk_notebook_get_nth_page" c_gtk_notebook_get_nth_page ::+	Ptr NTag -> #{type gint} -> IO (Ptr Gtk.Widget.WTag)
+ src/Stopgap/Graphics/UI/Gtk/NotebookPage.hsc view
@@ -0,0 +1,17 @@+{-# LANGUAGE ImportQualifiedPost #-}+{-# LANGUAGE TypeFamilies #-}+{-# OPTIONS_GHC -Wall -fno-warn-tabs #-}++module Stopgap.Graphics.UI.Gtk.NotebookPage where++import Foreign.Ptr+import Stopgap.Data.Ptr++import Stopgap.System.GLib.Object qualified as G.Object++data NTag++newtype N = N (Ptr NTag) deriving Show++instance IsPtr N where type Tag N = NTag; fromPtr = N; toPtr (N p) = p+instance G.Object.IsO N where toO (N n) = G.Object.O $ castPtr n
+ src/Stopgap/Graphics/UI/Gtk/ScrolledWindow.hsc view
@@ -0,0 +1,34 @@+{-# LANGUAGE ImportQualifiedPost #-}+{-# LANGUAGE ViewPatterns #-}+{-# LANGUAGE TypeFamilies #-}+{-# OPTIONS_GHC -Wall -fno-warn-tabs #-}++module Stopgap.Graphics.UI.Gtk.ScrolledWindow where++import Foreign.Ptr+import Stopgap.Data.Ptr++import Stopgap.Graphics.UI.Gtk.Widget qualified as Gtk.Widget+import Stopgap.System.GLib.Object qualified as G.Object++data STag++newtype S = S (Ptr STag) deriving Show++instance IsPtr S where type Tag S = STag; fromPtr = S; toPtr (S p) = p+instance G.Object.IsO S where toO (S p) = G.Object.O $ castPtr p+instance Gtk.Widget.IsW S where toW (S p) = Gtk.Widget.W $ castPtr p++new :: IO S+new = S <$> c_gtk_scrolled_window_new++foreign import ccall "gtk_scrolled_window_new" c_gtk_scrolled_window_new ::+	IO (Ptr STag)++setChild :: Gtk.Widget.IsW w => S -> w -> IO ()+setChild (S s) (Gtk.Widget.toW -> Gtk.Widget.W w) =+	c_gtk_scrolled_window_set_child s w++foreign import ccall "gtk_scrolled_window_set_child"+	c_gtk_scrolled_window_set_child ::+	Ptr STag -> Ptr Gtk.Widget.WTag -> IO ()
+ src/Stopgap/Graphics/UI/Gtk/TextBuffer.hsc view
@@ -0,0 +1,19 @@+{-# LANGUAGE BlockArguments #-}+{-# OPTIONS_GHC -Wall -fno-warn-tabs #-}++module Stopgap.Graphics.UI.Gtk.TextBuffer where++import Foreign.Ptr+import Foreign.C.Types+import Foreign.C.String++data TTag++newtype T = T (Ptr TTag) deriving Show++setText :: T -> String -> IO ()+setText (T t) txt = withCStringLen txt \(ctxt, len) ->+	c_gtk_text_buffer_set_text t ctxt $ fromIntegral len++foreign import ccall "gtk_text_buffer_set_text" c_gtk_text_buffer_set_text ::+	Ptr TTag -> CString -> CInt -> IO ()
+ src/Stopgap/Graphics/UI/Gtk/TextView.hsc view
@@ -0,0 +1,58 @@+{-# LANGUAGE ImportQualifiedPost #-}+{-# LANGUAGE TypeFamilies #-}+{-# LANGUAGE ViewPatterns #-}+{-# OPTIONS_GHC -Wall -fno-warn-tabs #-}++module Stopgap.Graphics.UI.Gtk.TextView where++import Foreign.Ptr+import Stopgap.Data.Ptr+import Data.Word+import Data.Int++import Stopgap.Graphics.UI.Gtk qualified as Gtk+import Stopgap.Graphics.UI.Gtk.Widget qualified as Gtk.Widget+import Stopgap.Graphics.UI.Gtk.TextBuffer qualified as Gtk.TextBuffer+import Stopgap.System.GLib.Object qualified as G.Object++#include <gtk/gtk.h>++class Gtk.Widget.IsW t => IsT t where toT :: t -> T++data TTag++newtype T = T (Ptr TTag) deriving Show++instance IsPtr T where type Tag T = TTag; fromPtr = T; toPtr (T p) = p+instance G.Object.IsO T where toO (T t) = G.Object.O $ castPtr t+instance Gtk.Widget.IsW T where toW (T t) = Gtk.Widget.W $ castPtr t+instance IsT T where toT = id++new :: IO T+new = T <$> c_gtk_text_view_new++foreign import ccall "gtk_text_view_new" c_gtk_text_view_new :: IO (Ptr TTag)++getBuffer :: IsT t => t -> IO Gtk.TextBuffer.T+getBuffer (toT -> T t) = Gtk.TextBuffer.T <$> c_gtk_text_view_get_buffer t++foreign import ccall "gtk_text_view_get_buffer" c_gtk_text_view_get_buffer ::+	Ptr TTag -> IO (Ptr Gtk.TextBuffer.TTag)++setWrapMode :: IsT t => t -> Gtk.WrapMode -> IO ()+setWrapMode (toT -> T t) (Gtk.WrapMode wm) = c_gtk_text_view_set_wrap_mode t wm++foreign import ccall "gtk_text_view_set_wrap_mode"+	c_gtk_text_view_set_wrap_mode ::+	Ptr TTag -> #{type GtkWrapMode} -> IO ()++setEditable :: IsT t => t -> Bool -> IO ()+setEditable (toT -> T t) b = c_gtk_text_view_set_editable t $ boolToGboolean b++boolToGboolean :: Bool -> #{type gboolean}+boolToGboolean False = #{const FALSE}+boolToGboolean True = #{const TRUE}++foreign import ccall "gtk_text_view_set_editable"+	c_gtk_text_view_set_editable ::+	Ptr TTag -> #{type gboolean} -> IO ()
+ src/Stopgap/Graphics/UI/Gtk/Widget.hsc view
@@ -0,0 +1,29 @@+{-# LANGUAGE ImportQualifiedPost #-}+{-# LANGUAGE ViewPatterns #-}+{-# 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.Gtk.EventController qualified as Gtk.EventController++class G.Object.IsO w => IsW w where toW :: w -> W++data WTag++newtype W = W (Ptr WTag) deriving Show++queueDraw :: IsW w => w -> IO ()+queueDraw (toW -> W w) = c_gtk_widget_queue_draw w++foreign import ccall "gtk_widget_queue_draw" c_gtk_widget_queue_draw ::+	Ptr WTag -> IO ()++addController :: (IsW w, Gtk.EventController.IsE e) => w -> e -> IO ()+addController (toW -> W w)+	(Gtk.EventController.toE -> Gtk.EventController.E e) =+	c_gtk_widget_add_controller w e++foreign import ccall "gtk_widget_add_controller" c_gtk_widget_add_controller ::+	Ptr WTag -> Ptr Gtk.EventController.ETag -> IO ()
+ src/Stopgap/Graphics/UI/Gtk/Window.hsc view
@@ -0,0 +1,69 @@+{-# LANGUAGE ImportQualifiedPost #-}+{-# LANGUAGE TypeFamilies #-}+{-# LANGUAGE ViewPatterns #-}+{-# OPTIONS_GHC -Wall -fno-warn-tabs #-}++module Stopgap.Graphics.UI.Gtk.Window where++import Foreign.Ptr+import Foreign.C.Types+import Foreign.C.String+import Stopgap.Data.Ptr++import Stopgap.Graphics.UI.Gtk.Application qualified as Gtk.Application+import Stopgap.Graphics.UI.Gtk.Widget qualified as Gtk.Widget+import Stopgap.System.GLib.Object qualified as G.Object++class Gtk.Widget.IsW a => IsW a where toW :: a -> W++data WTag++data W = W (Ptr WTag) deriving Show++instance IsPtr W where type Tag W = WTag; fromPtr = W; toPtr (W p) = p+instance G.Object.IsO W where toO (W w) = G.Object.O $ castPtr w+instance Gtk.Widget.IsW W where toW (W w) = Gtk.Widget.W $ castPtr w+instance IsW W where toW = id++new :: IO W+new = W <$> c_gtk_window_new++foreign import ccall "gtk_window_new" c_gtk_window_new :: IO (Ptr WTag)++setApplication :: IsW w => w -> Gtk.Application.A s -> IO ()+setApplication (toW -> W w) (Gtk.Application.A a) = c_gtk_window_set_application w a++foreign import ccall "gtk_window_set_application"+	c_gtk_window_set_application ::+	Ptr WTag -> Ptr (Gtk.Application.ATag) -> IO ()++present :: IsW w => w -> IO ()+present (toW -> W w) = c_gtk_window_present w++foreign import ccall "gtk_window_present" c_gtk_window_present ::+	Ptr WTag -> IO ()++setTitle :: IsW w => w -> String -> IO ()+setTitle (toW -> W w) ttl = withCString ttl $ c_gtk_window_set_title w++foreign import ccall "gtk_window_set_title" c_gtk_window_set_title ::+	Ptr WTag -> CString -> IO ()++setDefaultSize :: IsW w => w -> CInt -> CInt -> IO ()+setDefaultSize (toW -> W win) w h = c_gtk_window_set_default_size win w h++foreign import ccall "gtk_window_set_default_size"+	c_gtk_window_set_default_size :: Ptr WTag -> CInt -> CInt -> IO ()++setChild :: (IsW w, Gtk.Widget.IsW c) => w -> c -> IO ()+setChild (toW -> W win) (Gtk.Widget.toW -> Gtk.Widget.W cld) =+	c_gtk_window_set_child win cld++foreign import ccall "gtk_window_set_child" c_gtk_window_set_child ::+	Ptr WTag -> Ptr Gtk.Widget.WTag -> IO ()++destroy :: IsW w => w -> IO ()+destroy (toW -> W win) = c_gtk_window_destroy win++foreign import ccall "gtk_window_destroy" c_gtk_window_destroy ::+	Ptr WTag -> IO ()
+ src/Stopgap/System/GLib/Application.hsc view
@@ -0,0 +1,55 @@+{-# LANGUAGE TemplateHaskell #-}+{-# LANGUAGE BlockArguments, LambdaCase #-}+{-# LANGUAGE PatternSynonyms, ViewPatterns #-}+{-# OPTIONS_GHC -Wall -fno-warn-tabs #-}++module Stopgap.System.GLib.Application where++import Foreign.Ptr+import Foreign.Marshal.Array+import Foreign.C.Types+import Foreign.C.String+import Foreign.C.Enum+import Data.Word+import System.Exit++#include <gtk/gtk.h>++data ATag++data A = A (Ptr ATag) deriving Show++class IsA a where toA :: a -> A++instance IsA A where toA = id++run :: IsA a => a -> String -> [String] -> IO ExitCode+run (toA -> A pa) cmd as = toExitCode+	<$> withArgcArgv cmd as \argc argv -> c_g_application_run pa argc argv++withArgcArgv :: String -> [String] -> (CInt -> Ptr CString -> IO a) -> IO a+withArgcArgv cmd as f = withCStringList (cmd : as) \cas ->+	withArrayLen cas \argc argv -> f (fromIntegral argc) argv++withCStringList :: [String] -> ([CString] -> IO a) -> IO a+withCStringList [] f = f []+withCStringList (a : as) f =+	withCString a \ca -> withCStringList as \cas -> f $ ca : cas++toExitCode :: CInt -> ExitCode+toExitCode = \case 0 -> ExitSuccess; s -> ExitFailure $ fromIntegral s++foreign import ccall "g_application_run" c_g_application_run ::+	Ptr ATag -> CInt -> Ptr CString -> IO CInt++enum "Flags" ''#{type GApplicationFlags} [''Show, ''Read] [+	("DefaultFlags", #{const G_APPLICATION_DEFAULT_FLAGS}),+	("IsService", #{const G_APPLICATION_IS_SERVICE}),+	("IsLauncher", #{const G_APPLICATION_IS_LAUNCHER}),+	("HandlesOpen", #{const G_APPLICATION_HANDLES_OPEN}),+	("HandlesCommandLine", #{const G_APPLICATION_HANDLES_COMMAND_LINE}),+	("SendEnvironment", #{const G_APPLICATION_SEND_ENVIRONMENT}),+	("NonUnique", #{const G_APPLICATION_NON_UNIQUE}),+	("CanOverrideAppId", #{const G_APPLICATION_CAN_OVERRIDE_APP_ID}),+	("AllowReplacement", #{const G_APPLICATION_ALLOW_REPLACEMENT}),+	("Replace", #{const G_APPLICATION_REPLACE}) ]
+ src/Stopgap/System/GLib/Cancellable.hsc view
@@ -0,0 +1,20 @@+{-# OPTIONS_GHC -Wall -fno-warn-tabs #-}++module Stopgap.System.GLib.Cancellable where++import Foreign.Ptr++data CTag++newtype C = C (Ptr CTag) deriving Show++new :: IO C+new = C <$> c_g_cancellable_new++foreign import ccall "g_cancellable_new" c_g_cancellable_new :: IO (Ptr CTag)++cancel :: C -> IO ()+cancel (C c) = c_g_cancellable_cancel c++foreign import ccall "g_cancellable_cancel" c_g_cancellable_cancel ::+	Ptr CTag -> IO()
+ src/Stopgap/System/GLib/Error.hsc view
@@ -0,0 +1,58 @@+{-# LANGUAGE TemplateHaskell #-}+{-# LANGUAGE BlockArguments, LambdaCase, TupleSections #-}+{-# LANGUAGE ImplicitParams #-}+{-# LANGUAGE ExistentialQuantification #-}+{-# LANGUAGE PatternSynonyms, ViewPatterns #-}+{-# OPTIONS_GHC -Wall -fno-warn-tabs #-}++module Stopgap.System.GLib.Error where++import Control.Exception+import Control.Exception.Hierarchy+import Foreign.Ptr+import Foreign.C.String+import Foreign.C.Struct+import Foreign.Storable+import Data.Word+import Data.Int++#include <gtk/gtk.h>++type PGChar = Ptr #{type gchar}++struct "E_" #{size GError} #{alignment GError} [+	("domain_", ''#{type GQuark},+		[| #{peek GError, domain} |], [| #{poke GError, domain} |]),+	("code_", ''#{type gint},+		[| #{peek GError, code} |], [| #{poke GError, code} |]),+	("message_", ''PGChar,+		[| #{peek GError, message} |], [| #{poke GError, message} |])+	]+	[''Show, ''Storable]++type DomainCode = (#{type GQuark}, #{type gint})++data EOthers = EOthers {+	domainCode :: DomainCode,+	message :: String }++instance Show EOthers where+	show (EOthers (d, c) msg) = "Error: " ++ show d ++ " " ++ show c ++ " " ++ msg++exceptionHierarchy Nothing $ ExNode "E" [+	ExType ''EOthers ]++type MakeEFun = DomainCode -> String -> IO (Maybe E)++fromC :: (?makeEFuns :: [MakeEFun]) =>  E_ -> IO E+fromC E_ { e_Domain_ = d, e_Code_ = c, e_Message_ = cm } = do+	get ?makeEFuns =<< peekCString (castPtr cm)+	where+	get = \case+		[] -> pure . E . EOthers (d, c)+		f : fs -> \msg -> maybe (get fs msg) pure =<< f (d, c) msg++free :: Ptr E_ -> IO ()+free = c_g_error_free++foreign import ccall "g_error_free" c_g_error_free :: Ptr E_ -> IO ()
+ src/Stopgap/System/GLib/Error/Io.hsc view
@@ -0,0 +1,41 @@+{-# LANGUAGE ImportQualifiedPost #-}+{-# LANGUAGE CApiFFI #-}+{-# LANGUAGE TemplateHaskell #-}+{-# LANGUAGE BlockArguments #-}+{-# LANGUAGE PatternSynonyms #-}+{-# OPTIONS_GHC -Wall -fno-warn-tabs #-}++module Stopgap.System.GLib.Error.Io where++import Foreign.C.Enum+import Control.Exception+import Control.Exception.Hierarchy+import Data.Word++import Stopgap.System.GLib.Error qualified as G.Error+import Stopgap.System.GLib.Error qualified++#include <gtk/gtk.h>++enum "I_" ''#{type GFileError} [''Show, ''Read] [+	("Failed", #{const G_IO_ERROR_FAILED}),+	("NotFound", #{const G_IO_ERROR_NOT_FOUND}),++	("PermissionDenied", #{const G_IO_ERROR_PERMISSION_DENIED})+	]++data I = I { iCode :: I_, iMessage :: String }++instance Show I where+	show (I c msg) = "Error: " ++ show c ++ " " ++ msg++exceptionHierarchy (Just ''G.Error.E) $ ExType ''I++foreign import capi "gtk/gtk.h value G_IO_ERROR" c_G_IO_ERROR :: #{type GQuark}++mkEFun :: G.Error.DomainCode -> String -> IO (Maybe G.Error.E)+mkEFun (d, c) msg = do+	let	d0 = c_G_IO_ERROR+	pure if d == d0+	then Just . G.Error.E $ I (I_ $ fromIntegral c) msg+	else Nothing
+ src/Stopgap/System/GLib/File.hsc view
@@ -0,0 +1,63 @@+{-# LANGUAGE ImportQualifiedPost #-}+{-# LANGUAGE BlockArguments, LambdaCase #-}+{-# LANGUAGE ImplicitParams #-}+{-# LANGUAGE TypeFamilies #-}+{-# LANGUAGE ViewPatterns #-}+{-# OPTIONS_GHC -Wall -fno-warn-tabs #-}++module Stopgap.System.GLib.File where++import Foreign.Ptr+import Foreign.Marshal.Alloc+import Foreign.Storable+import Foreign.C.String+import Control.Monad+import Control.Exception+import Data.Word+import Data.Int+import Stopgap.Data.Ptr++import Stopgap.System.GLib.Error qualified as G.Error+import Stopgap.System.GLib.Cancellable qualified as G.Cancellable++#include <gtk/gtk.h>++data FTag++newtype F = F (Ptr FTag) deriving Show++instance IsPtr F where type Tag F = FTag; fromPtr = F; toPtr (F p) = p++newForPath :: FilePath -> IO F+newForPath fp = F <$> withCString fp c_g_file_new_for_path++foreign import ccall "g_file_new_for_path" c_g_file_new_for_path ::+	CString -> IO (Ptr FTag)++loadContents :: (?makeEFuns :: [G.Error.MakeEFun]) =>+	F -> Maybe G.Cancellable.C -> IO (String, String)+loadContents (F f) (cancellableToPtr -> c) =+	alloca \pcnt -> alloca \plen -> alloca \petag -> alloca \pperr -> do+		rslt <- c_g_file_load_contents f c pcnt plen petag pperr+		when (rslt == #{const FALSE}) do+			perr <- peek pperr+			err <- G.Error.fromC =<< peek perr+			G.Error.free perr+			throw err+		cntlen <- (,) <$> peek pcnt <*> (fromIntegral <$> peek plen)+		cetag <- peek petag+		(,) <$> peekCStringLen cntlen <*> peekCString cetag++cancellableToPtr :: Maybe G.Cancellable.C -> Ptr G.Cancellable.CTag+cancellableToPtr = \case Nothing -> nullPtr; Just (G.Cancellable.C p) -> p++foreign import ccall "g_file_load_contents" c_g_file_load_contents ::+	Ptr FTag -> Ptr G.Cancellable.CTag -> Ptr CString ->+	Ptr #{type gsize} -> Ptr CString -> Ptr (Ptr G.Error.E_) ->+	IO #{type gboolean}++getBasename :: F -> IO String+getBasename (F f) = peekCString =<< c_g_file_get_basename f++foreign import ccall "g_file_get_basename" c_g_file_get_basename ::+	Ptr FTag -> IO CString
+ src/Stopgap/System/GLib/Idle.hsc view
@@ -0,0 +1,30 @@+{-# LANGUAGE LambdaCase #-}+{-# OPTIONS_GHC -Wall -fno-warn-tabs #-}++module Stopgap.System.GLib.Idle where++import Foreign.Ptr+import Data.Word+import Data.Int+import Stopgap.Data.Ptr++#include <gtk/gtk.h>++add :: IsPtr ud => (ud -> IO Bool) -> ud -> IO #{type guint}+add 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}))
+ src/Stopgap/System/GLib/Object.hsc view
@@ -0,0 +1,46 @@+{-# LANGUAGE CApiFFI #-}+{-# LANGUAGE BlockArguments #-}+{-# LANGUAGE ViewPatterns #-}+{-# OPTIONS_GHC -Wall -fno-warn-tabs #-}++module Stopgap.System.GLib.Object where++import Foreign.Ptr+import Foreign.C.String+import Data.Bool+import Data.Word+import Data.Int+import Stopgap.Data.Ptr++#include <glib.h>++data OTag++newtype O = O (Ptr OTag) deriving Show++class IsPtr o => IsO o where toO :: o -> O++withObject :: IsO o => IO o -> (o -> IO a) -> IO a+withObject cr f = do+	o <- cr+	f o <* unref o++unref :: IsO o => o -> IO ()+unref (toO -> O o) = c_g_object_unref o++foreign import ccall "g_object_unref" c_g_object_unref :: Ptr OTag -> IO ()++class Property p where toP :: p -> Either #{type guint64} #{type gint64}++instance Property Bool where toP = Left . bool #{const FALSE} #{const TRUE}++set :: (IsO o, Property p) => o -> String -> p -> IO ()+set (toO -> (O o)) n p = withCString n \cn -> either+	(\pp -> c_g_object_set_guint64 o (castPtr cn) pp nullPtr)+	(\pp -> c_g_object_set_gint64 o (castPtr cn) pp nullPtr) (toP p)++foreign import ccall "g_object_set" c_g_object_set_guint64 ::+	Ptr OTag -> Ptr #{type gchar} -> #{type guint64} -> Ptr () -> IO ()++foreign import ccall "g_object_set" c_g_object_set_gint64 ::+	Ptr OTag -> Ptr #{type gchar} -> #{type gint64} -> Ptr () -> IO ()
+ src/Stopgap/System/GLib/Signal.hsc view
@@ -0,0 +1,140 @@+{-# LANGUAGE CApiFFI #-}+{-# LANGUAGE BlockArguments, LambdaCase #-}+{-# LANGUAGE ScopedTypeVariables, TypeApplications #-}+{-# LANGUAGE TypeFamilies, TypeFamilyDependencies #-}+{-# OPTIONS_GHC -Wall -fno-warn-tabs #-}++module Stopgap.System.GLib.Signal where++import Foreign.Ptr+import Foreign.Marshal.Array+import Foreign.C.String+import Data.String+import Data.Int++import Stopgap.Data.Ptr++#include <gtk/gtk.h>++data Signal = Signal String deriving Show++instance IsString Signal where+	fromString = Signal++connect :: forall a b . (IsPtr a, IsPtr b) => a -> Signal -> (a -> b -> IO ()) -> b -> IO ()+connect x (Signal sig) h ud = withCString sig \csig -> wrapHandler h \ch ->+	c_g_signal_connect @(Tag a) @(Tag b) (toPtr @a x) csig ch (toPtr ud)++foreign import capi "gtk/gtk.h g_signal_connect" c_g_signal_connect ::+	Ptr a -> CString -> FunPtr (Ptr a -> Ptr b -> IO ()) -> Ptr b -> IO ()++wrapHandler :: (IsPtr a, IsPtr b) => (a -> b -> IO ()) ->+	(FunPtr (Ptr (Tag a) -> Ptr (Tag b) -> IO ()) -> IO c) -> IO c+wrapHandler h f = do+	let	g px pud = h (fromPtr px) (fromPtr pud)+	f =<< c_wrap_handler g++foreign import ccall "wrapper" c_wrap_handler ::+	(Ptr a -> Ptr b -> IO ()) -> IO (FunPtr (Ptr a -> Ptr b -> IO ()))++connectClose :: forall a b . (IsPtr a, IsPtr b) =>+	a -> Signal -> (a -> b -> IO Bool) -> b -> IO ()+connectClose x (Signal sig) h ud =+	withCString sig \csig -> wrapHandlerClose h >>= \ch ->+		c_g_signal_connect_close (toPtr x) csig ch (toPtr ud)++foreign import capi "gtk/gtk.h g_signal_connect" c_g_signal_connect_close ::+	Ptr a -> CString -> FunPtr (Ptr a -> Ptr b -> IO #{type gboolean}) ->+	Ptr b -> IO ()++wrapHandlerClose :: (IsPtr a, IsPtr b) => (a -> b -> IO Bool) ->+	IO (FunPtr (Ptr (Tag a) -> Ptr (Tag b) -> IO #{type gboolean}))+wrapHandlerClose h = do+	let	g px pud = boolToGboolean <$> h (fromPtr px) (fromPtr pud)+	c_wrap_handler_close g++boolToGboolean :: Bool -> #{type gboolean}+boolToGboolean = \case False -> #{const FALSE}; True -> #{const TRUE}++foreign import ccall "wrapper" c_wrap_handler_close ::+	(Ptr a -> Ptr b -> IO #{type gboolean}) ->+	IO (FunPtr (Ptr a -> Ptr b -> IO #{type gboolean}))++connectOpen :: forall a gf b . (IsPtr a, IsPtr gf, IsPtr b) =>+	a -> Signal -> HandlerOpen a gf b -> b -> IO ()+connectOpen x (Signal sig) h ud = withCString sig \csig -> do+	ch <- wrapHandlerOpen h+	c_g_signal_connect_open @(Tag a) @(Tag gf) @(Tag b) (toPtr x) csig ch (toPtr ud)++type HandlerOpen a gf b = a -> [gf] -> String -> b -> IO ()++type CHandlerOpen a gf b =+	Ptr a -> Ptr (Ptr gf) -> #{type gint} -> CString -> Ptr b -> IO ()++handlerOpenToC ::+	(IsPtr a, IsPtr gf, IsPtr b) =>+	HandlerOpen a gf b -> CHandlerOpen (Tag a) (Tag gf) (Tag b)+handlerOpenToC h pa ppgf n cstr pb = do+	pgfs <- peekArray (fromIntegral n) ppgf+	str <- peekCString cstr+	h (fromPtr pa) (fromPtr <$> pgfs) str (fromPtr pb)++foreign import capi "gtk/gtk.h g_signal_connect" c_g_signal_connect_open ::+	Ptr a -> CString -> FunPtr (CHandlerOpen a gf b) -> Ptr b -> IO ()++wrapHandlerOpen :: (IsPtr a, IsPtr gf, IsPtr b) => HandlerOpen a gf b ->+	IO (FunPtr (CHandlerOpen (Tag a) (Tag gf) (Tag b)))+wrapHandlerOpen h = c_wrap_handler_open $ handlerOpenToC h++foreign import ccall "wrapper" c_wrap_handler_open ::+	CHandlerOpen a gf b -> IO (FunPtr (CHandlerOpen a gf b))++foreign import capi "gtk/gtk.h G_CALLBACK" c_G_CALLBACK ::+	FunPtr (Ptr a -> Ptr b -> IO ()) -> FunPtr (Ptr a -> Ptr b -> IO ())++connectXY :: forall a b . (IsPtr a, IsPtr b) =>+	a -> Signal -> HandlerXY a b -> b -> IO ()+connectXY x (Signal sig) h ud = withCString sig \csig -> do+	ch <- wrapHandlerXY h+	c_g_signal_connect_xy @(Tag a) @(Tag b) (toPtr x) csig ch (toPtr ud)++foreign import capi "gtk/gtk.h g_signal_connect" c_g_signal_connect_xy ::+	Ptr a -> CString -> FunPtr (CHandlerXY a b) -> Ptr b -> IO ()++wrapHandlerXY :: (IsPtr a, IsPtr b) => HandlerXY a b ->+	IO (FunPtr (CHandlerXY (Tag a) (Tag b)))+wrapHandlerXY h = do+	let	g px x y pud = h (fromPtr px) x y (fromPtr pud)+	c_wrap_handler_xy g++type HandlerXY a b = a -> #{type gdouble} -> #{type gdouble} -> b -> IO ()++type CHandlerXY a b =+	Ptr a -> #{type gdouble} -> #{type gdouble} -> Ptr b -> IO ()++foreign import ccall "wrapper" c_wrap_handler_xy ::+	CHandlerXY a b -> IO (FunPtr (CHandlerXY a b))++connectNXY :: forall a b . (IsPtr a, IsPtr b) =>+	a -> Signal -> HandlerNXY a b -> b -> IO ()+connectNXY x (Signal sig) h ud = withCString sig \csig -> do+	ch <- wrapHandlerNXY h+	c_g_signal_connect_nxy @(Tag a) @(Tag b) (toPtr x) csig ch (toPtr ud)++foreign import capi "gtk/gtk.h g_signal_connect" c_g_signal_connect_nxy ::+	Ptr a -> CString -> FunPtr (CHandlerNXY a b) -> Ptr b -> IO ()++wrapHandlerNXY :: (IsPtr a, IsPtr b) => HandlerNXY a b ->+	IO (FunPtr (CHandlerNXY (Tag a) (Tag b)))+wrapHandlerNXY h = do+	let	g px n x y pud = h (fromPtr px) n x y (fromPtr pud)+	c_wrap_handler_nxy g++type HandlerNXY a b =+	a -> #{type gint} -> #{type gdouble} -> #{type gdouble} -> b -> IO ()++type CHandlerNXY a b = Ptr a ->+	#{type gint} -> #{type gdouble} -> #{type gdouble} -> Ptr b -> IO()++foreign import ccall "wrapper" c_wrap_handler_nxy ::+	CHandlerNXY a b -> IO (FunPtr (CHandlerNXY a b))
+ src/Stopgap/System/GLib/Timeout.hsc view
@@ -0,0 +1,33 @@+{-# LANGUAGE LambdaCase #-}+{-# OPTIONS_GHC -Wall -fno-warn-tabs #-}++module Stopgap.System.GLib.Timeout where++import Foreign.Ptr+import Data.Word+import Data.Int+import Stopgap.Data.Ptr++#include <gtk/gtk.h>++add :: IsPtr ud => #{type guint} -> (ud -> IO Bool) -> ud -> IO #{type guint}+add i f ud = do+	cf <- wrapHandler f+	c_g_timeout_add i cf $ toPtr ud++foreign import ccall "g_timeout_add" c_g_timeout_add ::+	#{type guint} -> 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}))
+ test/Spec.hs view
@@ -0,0 +1,2 @@+main :: IO ()+main = putStrLn "Test suite not yet implemented"